diff options
Diffstat (limited to 't/roles')
57 files changed, 5940 insertions, 0 deletions
diff --git a/t/roles/anonymous_roles.t b/t/roles/anonymous_roles.t new file mode 100644 index 0000000..53bfb34 --- /dev/null +++ b/t/roles/anonymous_roles.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +use Class::Load qw(is_class_loaded); + +my $role = Moose::Meta::Role->create_anon_role( + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet'); +$role->apply($class); +# XXX: Moose::Util::apply_all_roles doesn't cope with references yet + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +like($role->name, qr/^Moose::Meta::Role::__ANON__::SERIAL::\d+$/, ""); +ok($role->is_anon_role, "the role knows it's anonymous"); + +ok(is_class_loaded(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded"); +ok(Class::MOP::class_of(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of"); + +{ + my $role; + { + my $meta = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $role = $meta->name; + can_ok($role, 'foo'); + } + ok(!$role->can('foo')); +} + +{ + my $role; + { + my $meta = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $role = $meta->name; + can_ok($role, 'foo'); + Class::MOP::remove_metaclass_by_name($role); + } + ok(!$role->can('foo')); +} + +done_testing; diff --git a/t/roles/application_toclass.t b/t/roles/application_toclass.t new file mode 100644 index 0000000..b07bc80 --- /dev/null +++ b/t/roles/application_toclass.t @@ -0,0 +1,75 @@ +use strict; +use warnings; +use Test::More; + +do { + package Role::Foo; + use Moose::Role; + + sub foo { } + + + package Consumer::Basic; + use Moose; + + with 'Role::Foo'; + + package Consumer::Excludes; + use Moose; + + with 'Role::Foo' => { -excludes => 'foo' }; + + package Consumer::Aliases; + use Moose; + + with 'Role::Foo' => { -alias => { 'foo' => 'role_foo' } }; + + package Consumer::Overrides; + use Moose; + + with 'Role::Foo'; + + sub foo { } +}; + +my @basic = Consumer::Basic->meta->role_applications; +my @excludes = Consumer::Excludes->meta->role_applications; +my @aliases = Consumer::Aliases->meta->role_applications; +my @overrides = Consumer::Overrides->meta->role_applications; + +is(@basic, 1); +is(@excludes, 1); +is(@aliases, 1); +is(@overrides, 1); + +my $basic = $basic[0]; +my $excludes = $excludes[0]; +my $aliases = $aliases[0]; +my $overrides = $overrides[0]; + +isa_ok($basic, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($excludes, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($aliases, 'Moose::Meta::Role::Application::ToClass'); +isa_ok($overrides, 'Moose::Meta::Role::Application::ToClass'); + +is($basic->role, Role::Foo->meta); +is($excludes->role, Role::Foo->meta); +is($aliases->role, Role::Foo->meta); +is($overrides->role, Role::Foo->meta); + +is($basic->class, Consumer::Basic->meta); +is($excludes->class, Consumer::Excludes->meta); +is($aliases->class, Consumer::Aliases->meta); +is($overrides->class, Consumer::Overrides->meta); + +is_deeply($basic->get_method_aliases, {}); +is_deeply($excludes->get_method_aliases, {}); +is_deeply($aliases->get_method_aliases, { foo => 'role_foo' }); +is_deeply($overrides->get_method_aliases, {}); + +is_deeply($basic->get_method_exclusions, []); +is_deeply($excludes->get_method_exclusions, ['foo']); +is_deeply($aliases->get_method_exclusions, []); +is_deeply($overrides->get_method_exclusions, []); + +done_testing; diff --git a/t/roles/apply_role.t b/t/roles/apply_role.t new file mode 100644 index 0000000..d811d03 --- /dev/null +++ b/t/roles/apply_role.t @@ -0,0 +1,227 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package FooRole; + use Moose::Role; + + our $VERSION = 23; + + has 'bar' => ( is => 'rw', isa => 'FooClass' ); + has 'baz' => ( is => 'ro' ); + + sub goo {'FooRole::goo'} + sub foo {'FooRole::foo'} + + override 'boo' => sub { 'FooRole::boo -> ' . super() }; + + around 'blau' => sub { + my $c = shift; + 'FooRole::blau -> ' . $c->(); + }; +} + +{ + package BarRole; + use Moose::Role; + sub woot {'BarRole::woot'} +} + +{ + package BarClass; + use Moose; + + sub boo {'BarClass::boo'} + sub foo {'BarClass::foo'} # << the role overrides this ... +} + +{ + package FooClass; + use Moose; + + extends 'BarClass'; + + ::like( ::exception { with 'FooRole' => { -version => 42 } }, qr/FooRole version 42 required--this is only version 23/, 'applying role with unsatisfied version requirement' ); + + ::is( ::exception { with 'FooRole' => { -version => 13 } }, undef, 'applying role with satisfied version requirement' ); + + sub blau {'FooClass::blau'} # << the role wraps this ... + + sub goo {'FooClass::goo'} # << overrides the one from the role ... +} + +{ + package FooBarClass; + use Moose; + + extends 'FooClass'; + with 'FooRole', 'BarRole'; +} + +{ + package PlainJane; + sub new { return bless {}, __PACKAGE__; } +} + +my $foo_class_meta = FooClass->meta; +isa_ok( $foo_class_meta, 'Moose::Meta::Class' ); + +my $foobar_class_meta = FooBarClass->meta; +isa_ok( $foobar_class_meta, 'Moose::Meta::Class' ); + +isnt( exception { + $foo_class_meta->does_role(); +}, undef, '... does_role requires a role name' ); + +isnt( exception { + $foo_class_meta->add_role(); +}, undef, '... apply_role requires a role' ); + +isnt( exception { + $foo_class_meta->add_role( bless( {} => 'Fail' ) ); +}, undef, '... apply_role requires a role' ); + +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' ); + +ok( $foobar_class_meta->does_role('FooRole'), + '... the FooBarClass->meta does_role FooRole' ); +ok( $foobar_class_meta->does_role('BarRole'), + '... the FooBarClass->meta does_role BarRole' ); +ok( !$foobar_class_meta->does_role('OtherRole'), + '... the FooBarClass->meta !does_role OtherRole' ); + +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 ); + ok( $foobar_class_meta->has_method($method_name), + '... FooBarClass has the method ' . $method_name ); +} + +ok( !$foo_class_meta->has_method('woot'), + '... FooClass lacks the method woot' ); +ok( $foobar_class_meta->has_method('woot'), + '... FooBarClass has the method woot' ); + +foreach my $attr_name (qw(bar baz)) { + ok( $foo_class_meta->has_attribute($attr_name), + '... FooClass has the attribute ' . $attr_name ); + ok( $foobar_class_meta->has_attribute($attr_name), + '... FooBarClass has the attribute ' . $attr_name ); +} + +can_ok( 'FooClass', 'does' ); +ok( FooClass->does('FooRole'), '... the FooClass does FooRole' ); +ok( !FooClass->does('BarRole'), '... the FooClass does not do BarRole' ); +ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' ); + +can_ok( 'FooBarClass', 'does' ); +ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' ); +ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' ); +ok( !FooBarClass->does('OtherRole'), + '... the FooBarClass does not do OtherRole' ); + +my $foo = FooClass->new(); +isa_ok( $foo, 'FooClass' ); + +my $foobar = FooBarClass->new(); +isa_ok( $foobar, 'FooBarClass' ); + +is( $foo->goo, 'FooClass::goo', '... got the right value of goo' ); +is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' ); + +is( $foo->boo, 'FooRole::boo -> BarClass::boo', + '... got the right value from ->boo' ); +is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', + '... got the right value from ->boo (double wrapped)' ); + +is( $foo->blau, 'FooRole::blau -> FooClass::blau', + '... got the right value from ->blau' ); +is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', + '... got the right value from ->blau' ); + +foreach my $foo ( $foo, $foobar ) { + can_ok( $foo, 'does' ); + ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' ); + ok( !$foo->does('OtherRole'), + '... and instance of FooClass does not do OtherRole' ); + + can_ok( $foobar, 'does' ); + ok( $foobar->does('FooRole'), + '... an instance of FooBarClass does FooRole' ); + ok( $foobar->does('BarRole'), + '... an instance of FooBarClass does BarRole' ); + ok( !$foobar->does('OtherRole'), + '... and instance of FooBarClass does not do OtherRole' ); + + for my $method (qw/bar baz foo boo goo blau/) { + can_ok( $foo, $method ); + } + + is( $foo->foo, 'FooRole::foo', '... got the right value of foo' ); + + ok( !defined( $foo->baz ), '... $foo->baz is undefined' ); + ok( !defined( $foo->bar ), '... $foo->bar is undefined' ); + + isnt( exception { + $foo->baz(1); + }, undef, '... baz is a read-only accessor' ); + + isnt( exception { + $foo->bar(1); + }, undef, '... bar is a read-write accessor with a type constraint' ); + + my $foo2 = FooClass->new(); + isa_ok( $foo2, 'FooClass' ); + + is( exception { + $foo->bar($foo2); + }, undef, '... bar is a read-write accessor with a type constraint' ); + + is( $foo->bar, $foo2, '... got the right value for bar now' ); +} + +{ + { + package MRole; + use Moose::Role; + sub meth { } + } + + { + package MRole2; + use Moose::Role; + sub meth2 { } + } + + { + use Moose::Meta::Class; + use Moose::Object; + use Moose::Util qw(apply_all_roles); + + my $class = Moose::Meta::Class->create( 'Class' => ( + superclasses => [ 'Moose::Object' ], + )); + + apply_all_roles($class, MRole->meta, MRole2->meta); + + ok(Class->can('meth'), "can meth"); + ok(Class->can('meth2'), "can meth2"); + } +} + +{ + ok(!Moose::Util::find_meta('PlainJane'), 'not initialized'); + Moose::Util::apply_all_roles('PlainJane', 'BarRole'); + ok(Moose::Util::find_meta('PlainJane'), 'initialized'); + ok(Moose::Util::find_meta('PlainJane')->does_role('BarRole'), 'does BarRole'); + my $pj = PlainJane->new(); + ok($pj->can('woot'), 'can woot'); +} + +done_testing; diff --git a/t/roles/build.t b/t/roles/build.t new file mode 100644 index 0000000..8094b90 --- /dev/null +++ b/t/roles/build.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +# this test script ensures that my idiom of: +# role: sub BUILD, after BUILD +# continues to work to run code after object initialization, whether the class +# has a BUILD method or not + +my @CALLS; + +do { + package TestRole; + use Moose::Role; + + sub BUILD { push @CALLS, 'TestRole::BUILD' } + before BUILD => sub { push @CALLS, 'TestRole::BUILD:before' }; + after BUILD => sub { push @CALLS, 'TestRole::BUILD:after' }; +}; + +do { + package ClassWithBUILD; + use Moose; + + ::stderr_is { + with 'TestRole'; + } ''; + + sub BUILD { push @CALLS, 'ClassWithBUILD::BUILD' } +}; + +do { + package ExplicitClassWithBUILD; + use Moose; + + ::stderr_is { + with 'TestRole' => { -excludes => 'BUILD' }; + } ''; + + sub BUILD { push @CALLS, 'ExplicitClassWithBUILD::BUILD' } +}; + +do { + package ClassWithoutBUILD; + use Moose; + with 'TestRole'; +}; + +{ + is_deeply([splice @CALLS], [], "no calls to BUILD yet"); + + ClassWithBUILD->new; + + is_deeply([splice @CALLS], [ + 'TestRole::BUILD:before', + 'ClassWithBUILD::BUILD', + 'TestRole::BUILD:after', + ]); + + ClassWithoutBUILD->new; + + is_deeply([splice @CALLS], [ + 'TestRole::BUILD:before', + 'TestRole::BUILD', + 'TestRole::BUILD:after', + ]); + + if (ClassWithBUILD->meta->is_mutable) { + ClassWithBUILD->meta->make_immutable; + ClassWithoutBUILD->meta->make_immutable; + redo; + } +} + +done_testing; diff --git a/t/roles/conflict_many_methods.t b/t/roles/conflict_many_methods.t new file mode 100644 index 0000000..af149d7 --- /dev/null +++ b/t/roles/conflict_many_methods.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Bomb; + use Moose::Role; + + sub fuse { } + sub explode { } + + package Spouse; + use Moose::Role; + + sub fuse { } + sub explode { } + + package Caninish; + use Moose::Role; + + sub bark { } + + package Treeve; + use Moose::Role; + + sub bark { } +} + +{ + package PracticalJoke; + use Moose; + + ::like( ::exception { + with 'Bomb', 'Spouse'; + }, qr/Due to method name conflicts in roles 'Bomb' and 'Spouse', the methods 'explode' and 'fuse' must be implemented or excluded by 'PracticalJoke'/ ); + + ::like( ::exception { + with ( + 'Bomb', 'Spouse', + 'Caninish', 'Treeve', + ); + }, qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke'/ ); +} + +done_testing; diff --git a/t/roles/create_role.t b/t/roles/create_role.t new file mode 100644 index 0000000..ce70465 --- /dev/null +++ b/t/roles/create_role.t @@ -0,0 +1,39 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +my $role = Moose::Meta::Role->create( + 'MyItem::Role::Equipment', + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet' => + roles => ['MyItem::Role::Equipment'], +); + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +ok(!$role->is_anon_role, "the role is not anonymous"); + +my $composed_role = Moose::Meta::Role->create( + 'MyItem::Role::Equipment2', + roles => [ $role ], +); + +ok($composed_role->does_role('MyItem::Role::Equipment2'), "Role composed into role"); + +done_testing; diff --git a/t/roles/create_role_subclass.t b/t/roles/create_role_subclass.t new file mode 100644 index 0000000..c5795cb --- /dev/null +++ b/t/roles/create_role_subclass.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; +use Moose (); + +do { + package My::Meta::Role; + use Moose; + extends 'Moose::Meta::Role'; + + has test_serial => ( + is => 'ro', + isa => 'Int', + default => 1, + ); + + no Moose; +}; + +my $role = My::Meta::Role->create_anon_role; +is($role->test_serial, 1, "default value for the serial attribute"); + +my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9); +is($nine_role->test_serial, 9, "parameter value for the serial attribute"); + +done_testing; diff --git a/t/roles/empty_method_modifiers_meta_bug.t b/t/roles/empty_method_modifiers_meta_bug.t new file mode 100644 index 0000000..28f9274 --- /dev/null +++ b/t/roles/empty_method_modifiers_meta_bug.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::More; + +# test role and class +package SomeRole; +use Moose::Role; + +requires 'foo'; + +package SomeClass; +use Moose; +has 'foo' => (is => 'rw'); +with 'SomeRole'; + +package main; + +#my $c = SomeClass->new; +#isa_ok( $c, 'SomeClass'); + +for my $modifier_type (qw[ before around after ]) { + my $get_func = "get_${modifier_type}_method_modifiers"; + my @mms = eval{ SomeRole->meta->$get_func('foo') }; + is($@, '', "$get_func for no method mods does not die"); + is(scalar(@mms),0,'is an empty list'); +} + +done_testing; diff --git a/t/roles/extending_role_attrs.t b/t/roles/extending_role_attrs.t new file mode 100644 index 0000000..d1841ab --- /dev/null +++ b/t/roles/extending_role_attrs.t @@ -0,0 +1,184 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=pod + +This basically just makes sure that using +name +on role attributes works right. + +=cut + +{ + package Foo::Role; + use Moose::Role; + + has 'bar' => ( + is => 'rw', + isa => 'Int', + default => sub { 10 }, + ); + + package Foo; + use Moose; + + with 'Foo::Role'; + + ::is( ::exception { + has '+bar' => (default => sub { 100 }); + }, undef, '... extended the attribute successfully' ); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->bar, 100, '... got the extended attribute'); + + +{ + package Bar::Role; + use Moose::Role; + + has 'foo' => ( + is => 'rw', + isa => 'Str | Int', + ); + + package Bar; + use Moose; + + with 'Bar::Role'; + + ::is( ::exception { + has '+foo' => ( + isa => 'Int', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $bar = Bar->new(foo => 42); +isa_ok($bar, 'Bar'); +is($bar->foo, 42, '... got the extended attribute'); +$bar->foo(100); +is($bar->foo, 100, "... can change the attribute's value to an Int"); + +like( exception { $bar->foo("baz") }, qr/^Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Int' with value .*baz.* at / ); +is($bar->foo, 100, "... still has the old Int value"); + + +{ + package Baz::Role; + use Moose::Role; + + has 'baz' => ( + is => 'rw', + isa => 'Value', + ); + + package Baz; + use Moose; + + with 'Baz::Role'; + + ::is( ::exception { + has '+baz' => ( + isa => 'Int | ClassName', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $baz = Baz->new(baz => 99); +isa_ok($baz, 'Baz'); +is($baz->baz, 99, '... got the extended attribute'); +$baz->baz('Foo'); +is($baz->baz, 'Foo', "... can change the attribute's value to a ClassName"); + +like( exception { $baz->baz("zonk") }, qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'ClassName\|Int' with value .*zonk.* at / ); +is_deeply($baz->baz, 'Foo', "... still has the old ClassName value"); + + +{ + package Quux::Role; + use Moose::Role; + + has 'quux' => ( + is => 'rw', + isa => 'Str | Int | Ref', + ); + + package Quux; + use Moose; + use Moose::Util::TypeConstraints; + + with 'Quux::Role'; + + subtype 'Positive' + => as 'Int' + => where { $_ > 0 }; + + ::is( ::exception { + has '+quux' => ( + isa => 'Positive | ArrayRef', + ) + }, undef, "... narrowed the role's type constraint successfully" ); +} + +my $quux = Quux->new(quux => 99); +isa_ok($quux, 'Quux'); +is($quux->quux, 99, '... got the extended attribute'); +$quux->quux(100); +is($quux->quux, 100, "... can change the attribute's value to an Int"); +$quux->quux(["hi"]); +is_deeply($quux->quux, ["hi"], "... can change the attribute's value to an ArrayRef"); + +like( exception { $quux->quux("quux") }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .*quux.* at / ); +is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); + +like( exception { $quux->quux({a => 1}) }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .+ at / ); +is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); + + +{ + package Err::Role; + use Moose::Role; + + for (1..3) { + has "err$_" => ( + isa => 'Str | Int', + is => 'bare', + ); + } + + package Err; + use Moose; + + with 'Err::Role'; + + ::is( ::exception { + has '+err1' => (isa => 'Defined'); + }, undef, "can get less specific in the subclass" ); + + ::is( ::exception { + has '+err2' => (isa => 'Bool'); + }, undef, "or change the type completely" ); + + ::is( ::exception { + has '+err3' => (isa => 'Str | ArrayRef'); + }, undef, "or add new types to the union" ); +} + +{ + package Role::With::PlusAttr; + use Moose::Role; + + with 'Foo::Role'; + + ::like( ::exception { + has '+bar' => ( is => 'ro' ); + }, qr/has '\+attr' is not supported in roles/, "Test has '+attr' in roles explodes" ); +} + +done_testing; diff --git a/t/roles/free_anonymous_roles.t b/t/roles/free_anonymous_roles.t new file mode 100644 index 0000000..98ce5dc --- /dev/null +++ b/t/roles/free_anonymous_roles.t @@ -0,0 +1,62 @@ +use strict; +use warnings; +use Test::More; +use Moose (); +use Scalar::Util 'weaken'; + +my $weak; +my $name; +do { + my $anon_class; + + do { + my $role = Moose::Meta::Role->create_anon_role( + methods => { + improperly_freed => sub { 1 }, + }, + ); + weaken($weak = $role); + + $name = $role->name; + + $anon_class = Moose::Meta::Class->create_anon_class( + roles => [ $role->name ], + ); + }; + + ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); + ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); +}; + +ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed"); + +ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries"); + +do { + my $anon_class; + + do { + my $role = Moose::Meta::Role->create_anon_role( + methods => { + improperly_freed => sub { 1 }, + }, + weaken => 0, + ); + weaken($weak = $role); + + $name = $role->name; + + $anon_class = Moose::Meta::Class->create_anon_class( + roles => [ $role->name ], + ); + }; + + ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); + ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); +}; + +ok($weak, "the role metaclass still exists because we told it not to weaken"); + +ok($name->can('improperly_freed'), "the symbol table still exists too"); + +done_testing; diff --git a/t/roles/imported_required_method.t b/t/roles/imported_required_method.t new file mode 100644 index 0000000..4c2e080 --- /dev/null +++ b/t/roles/imported_required_method.t @@ -0,0 +1,58 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +BEGIN { + package ExportsFoo; + use Sub::Exporter -setup => { + exports => ['foo'], + }; + + sub foo { 'FOO' } + + $INC{'ExportsFoo.pm'} = 1; +} + +{ + package Foo; + use Moose::Role; + requires 'foo'; +} + +{ + package Bar; + use Moose::Role; + requires 'bar'; +} + +{ + package Class; + use Moose; + use ExportsFoo 'foo'; + + # The grossness near the end of the regex works around a bug with \Q not + # escaping \& properly with perl 5.8.x + ::like( + ::exception { with 'Foo' }, + qr/^\Q'Foo' requires the method 'foo' to be implemented by 'Class'. If you imported functions intending to use them as methods, you need to explicitly mark them as such, via Class->meta->add_method(foo => \E\\\&foo\)/, + "imported 'method' isn't seen" + ); + Class->meta->add_method(foo => \&foo); + ::is( + ::exception { with 'Foo' }, + undef, + "now it's a method" + ); + + ::like( + ::exception { with 'Bar' }, + qr/^\Q'Bar' requires the method 'bar' to be implemented by 'Class' at/, + "requirement isn't imported, so don't give the extra info in the error" + ); +} + +does_ok('Class', 'Foo'); + +done_testing; diff --git a/t/roles/meta_role.t b/t/roles/meta_role.t new file mode 100644 index 0000000..284d28b --- /dev/null +++ b/t/roles/meta_role.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role; +use Moose::Util::TypeConstraints (); + +{ + package FooRole; + + our $VERSION = '0.01'; + + sub foo { 'FooRole::foo' } +} + +my $foo_role = Moose::Meta::Role->initialize('FooRole'); +isa_ok($foo_role, 'Moose::Meta::Role'); +isa_ok($foo_role, 'Class::MOP::Module'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); + +isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); + +is_deeply( + [ $foo_role->get_method_list() ], + [ 'foo' ], + '... got the right method list'); + +# attributes ... + +is_deeply( + [ $foo_role->get_attribute_list() ], + [], + '... got the right attribute list'); + +ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); + +is( exception { + $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo')); +}, undef, '... added the bar attribute okay' ); + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'bar' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +my $bar = $foo_role->get_attribute('bar'); +is_deeply( $bar->original_options, { is => 'rw', isa => 'Foo' }, + 'original options for bar attribute' ); +my $bar_for_class = $bar->attribute_for_class('Moose::Meta::Attribute'); +is( + $bar_for_class->type_constraint, + Moose::Util::TypeConstraints::class_type('Foo'), + 'bar has a Foo class type' +); + +is( exception { + $foo_role->add_attribute('baz' => (is => 'ro')); +}, undef, '... added the baz attribute okay' ); + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +my $baz = $foo_role->get_attribute('baz'); +is_deeply( $baz->original_options, { is => 'ro' }, + 'original options for baz attribute' ); + +is( exception { + $foo_role->remove_attribute('bar'); +}, undef, '... removed the bar attribute okay' ); + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'baz' ], + '... got the right attribute list'); + +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" }; +is( exception { + $foo_role->add_before_method_modifier('boo' => $method); +}, undef, '... 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'); + +done_testing; diff --git a/t/roles/method_aliasing_in_composition.t b/t/roles/method_aliasing_in_composition.t new file mode 100644 index 0000000..c94fad9 --- /dev/null +++ b/t/roles/method_aliasing_in_composition.t @@ -0,0 +1,206 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + requires 'role_bar'; + + package My::Class; + use Moose; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); + + package My::Class::Failure; + use Moose; + + ::like( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds' ); + + sub role_bar { 'FAIL' } +} + +ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz bar role_bar); + +{ + package My::OtherRole; + use Moose::Role; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); + + sub bar { 'My::OtherRole::bar' } + + package My::OtherRole::Failure; + use Moose::Role; + + ::like( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, qr/Cannot create a method alias if a local method of the same name exists/, '... cannot alias to a name that exists' ); + + sub role_bar { 'FAIL' } +} + +ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); +ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); +ok(!My::OtherRole->meta->requires_method('role_bar'), '... and the &role_bar method is not required'); + +{ + package My::AliasingRole; + use Moose::Role; + + ::is( ::exception { + with 'My::Role' => { -alias => { bar => 'role_bar' } }; + }, undef, '... this succeeds' ); +} + +ok(My::AliasingRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); +ok(!My::AliasingRole->meta->requires_method('bar'), '... and the &bar method is not required'); + +{ + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + + package My::Foo::Class; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); + + package My::Foo::Class::Broken; + use Moose; + + ::like( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, qr/Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo_foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); +} + +{ + my $foo = My::Foo::Class->new; + isa_ok($foo, 'My::Foo::Class'); + can_ok($foo, $_) for qw/foo foo_foo bar_foo/; + is($foo->foo, 'Baz::Role::foo', '... got the right method'); + is($foo->foo_foo, 'Foo::Role::foo', '... got the right method'); + is($foo->bar_foo, 'Bar::Role::foo', '... got the right method'); +} + +{ + package My::Foo::Role; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::Role->meta->has_method($_), "we have a $_ method") for qw/foo foo_foo bar_foo/;; +ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); + + +{ + package My::Foo::Role::Other; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(!My::Foo::Role::Other->meta->has_method('foo_foo'), "we dont have a foo_foo method"); +ok(My::Foo::Role::Other->meta->requires_method('foo_foo'), '... and the &foo method is required'); + +{ + package My::Foo::AliasOnly; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' } }, + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::AliasOnly->meta->has_method('foo'), 'we have a foo method'); +ok(My::Foo::AliasOnly->meta->has_method('foo_foo'), '.. and the aliased foo_foo method'); + +{ + package Role::Foo; + use Moose::Role; + + sub x1 {} + sub y1 {} +} + +{ + package Role::Bar; + use Moose::Role; + + ::is( ::exception { + with 'Role::Foo' => { + -alias => { x1 => 'foo_x1' }, + -excludes => ['y1'], + }; + }, undef, 'Compose Role::Foo into Role::Bar with alias and exclude' ); + + sub x1 {} + sub y1 {} +} + +{ + my $bar = Role::Bar->meta; + ok( $bar->has_method($_), "has $_ method" ) + for qw( x1 y1 foo_x1 ); +} + +{ + package Role::Baz; + use Moose::Role; + + ::is( ::exception { + with 'Role::Foo' => { + -alias => { x1 => 'foo_x1' }, + -excludes => ['y1'], + }; + }, undef, 'Compose Role::Foo into Role::Baz with alias and exclude' ); +} + +{ + my $baz = Role::Baz->meta; + ok( $baz->has_method($_), "has $_ method" ) + for qw( x1 foo_x1 ); + ok( ! $baz->has_method('y1'), 'Role::Baz has no y1 method' ); +} + +done_testing; diff --git a/t/roles/method_exclusion_in_composition.t b/t/roles/method_exclusion_in_composition.t new file mode 100644 index 0000000..ce7e233 --- /dev/null +++ b/t/roles/method_exclusion_in_composition.t @@ -0,0 +1,110 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package My::Role; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package My::Class; + use Moose; + + with 'My::Role' => { -excludes => 'bar' }; +} + +ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz); +ok(!My::Class->meta->has_method('bar'), '... but we excluded bar'); + +{ + package My::OtherRole; + use Moose::Role; + + with 'My::Role' => { -excludes => 'foo' }; + + sub foo { 'My::OtherRole::foo' } + sub bar { 'My::OtherRole::bar' } +} + +ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo bar baz); + +ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required'); +ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); + +{ + package Foo::Role; + use Moose::Role; + + sub foo { 'Foo::Role::foo' } + + package Bar::Role; + use Moose::Role; + + sub foo { 'Bar::Role::foo' } + + package Baz::Role; + use Moose::Role; + + sub foo { 'Baz::Role::foo' } + + package My::Foo::Class; + use Moose; + + ::is( ::exception { + with 'Foo::Role' => { -excludes => 'foo' }, + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); + + package My::Foo::Class::Broken; + use Moose; + + ::like( ::exception { + with 'Foo::Role', + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, qr/Due to a method name conflict in roles 'Baz::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); +} + +{ + my $foo = My::Foo::Class->new; + isa_ok($foo, 'My::Foo::Class'); + can_ok($foo, 'foo'); + is($foo->foo, 'Baz::Role::foo', '... got the right method'); +} + +{ + package My::Foo::Role; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role' => { -excludes => 'foo' }, + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(My::Foo::Role->meta->has_method('foo'), "we have a foo method"); +ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); + +{ + package My::Foo::Role::Other; + use Moose::Role; + + ::is( ::exception { + with 'Foo::Role', + 'Bar::Role' => { -excludes => 'foo' }, + 'Baz::Role'; + }, undef, '... composed our roles correctly' ); +} + +ok(!My::Foo::Role::Other->meta->has_method('foo'), "we dont have a foo method"); +ok(My::Foo::Role::Other->meta->requires_method('foo'), '... and the &foo method is required'); + +done_testing; diff --git a/t/roles/method_modifiers.t b/t/roles/method_modifiers.t new file mode 100644 index 0000000..b3076a6 --- /dev/null +++ b/t/roles/method_modifiers.t @@ -0,0 +1,89 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +my $FooRole; +{ + package Foo::Role; + use Moose::Role; + after foo => sub { $FooRole++ }; +} + +{ + package Foo; + use Moose; + with 'Foo::Role'; + sub foo { } +} + +Foo->foo; +is($FooRole, 1, "modifier called"); + +my $BarRole; +{ + package Bar::Role; + use Moose::Role; + after ['foo', 'bar'] => sub { $BarRole++ }; +} + +{ + package Bar; + use Moose; + with 'Bar::Role'; + sub foo { } + sub bar { } +} + +Bar->foo; +is($BarRole, 1, "modifier called"); +Bar->bar; +is($BarRole, 2, "modifier called"); + +my $BazRole; +{ + package Baz::Role; + use Moose::Role; + after 'foo', 'bar' => sub { $BazRole++ }; +} + +{ + package Baz; + use Moose; + with 'Baz::Role'; + sub foo { } + sub bar { } +} + +Baz->foo; +is($BazRole, 1, "modifier called"); +Baz->bar; +is($BazRole, 2, "modifier called"); + +my $QuuxRole; +{ + package Quux::Role; + use Moose::Role; + { our $TODO; local $TODO = "can't handle regexes yet"; + ::is( ::exception { + after qr/foo|bar/ => sub { $QuuxRole++ } + }, undef ); + } +} + +{ + package Quux; + use Moose; + with 'Quux::Role'; + sub foo { } + sub bar { } +} + +{ local $TODO = "can't handle regexes yet"; +Quux->foo; +is($QuuxRole, 1, "modifier called"); +Quux->bar; +is($QuuxRole, 2, "modifier called"); +} + +done_testing; diff --git a/t/roles/methods.t b/t/roles/methods.t new file mode 100644 index 0000000..b401d1c --- /dev/null +++ b/t/roles/methods.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Role (); + +my $test1 = Moose::Meta::Role->create_anon_role; +$test1->add_method( 'foo1', sub { } ); + +ok( $test1->has_method('foo1'), 'anon role has a foo1 method' ); + +my $t1_am = $test1->get_method('foo1')->associated_metaclass; + +ok( $t1_am, 'associated_metaclass is defined' ); + +isa_ok( + $t1_am, 'Moose::Meta::Role', + 'associated_metaclass is correct class' +); + +like( $t1_am->name(), qr/::__ANON__::/, + 'associated_metaclass->name looks like an anonymous class' ); + +{ + package Test2; + + use Moose::Role; + + sub foo2 { } +} + +ok( Test2->meta->has_method('foo2'), 'Test2 role has a foo2 method' ); + +my $t2_am = Test2->meta->get_method('foo2')->associated_metaclass; + +ok( $t2_am, 'associated_metaclass is defined' ); + +isa_ok( + $t2_am, 'Moose::Meta::Role', + 'associated_metaclass is correct class' +); + +is( $t2_am->name(), 'Test2', + 'associated_metaclass->name is Test2' ); + +done_testing; diff --git a/t/roles/more_alias_and_exclude.t b/t/roles/more_alias_and_exclude.t new file mode 100644 index 0000000..18b0f18 --- /dev/null +++ b/t/roles/more_alias_and_exclude.t @@ -0,0 +1,88 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + sub gorch { 'Foo::gorch' } + + package Bar; + use Moose::Role; + + sub foo { 'Bar::foo' } + sub bar { 'Bar::bar' } + sub baz { 'Bar::baz' } + sub gorch { 'Bar::gorch' } + + package Baz; + use Moose::Role; + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub baz { 'Baz::baz' } + sub gorch { 'Baz::gorch' } + + package Gorch; + use Moose::Role; + + sub foo { 'Gorch::foo' } + sub bar { 'Gorch::bar' } + sub baz { 'Gorch::baz' } + sub gorch { 'Gorch::gorch' } +} + +{ + package My::Class; + use Moose; + + ::is( ::exception { + with 'Foo' => { -excludes => [qw/bar baz gorch/], -alias => { gorch => 'foo_gorch' } }, + 'Bar' => { -excludes => [qw/foo baz gorch/] }, + 'Baz' => { -excludes => [qw/foo bar gorch/], -alias => { foo => 'baz_foo', bar => 'baz_bar' } }, + 'Gorch' => { -excludes => [qw/foo bar baz/] }; + }, undef, '... everything works out all right' ); +} + +my $c = My::Class->new; +isa_ok($c, 'My::Class'); + +is($c->foo, 'Foo::foo', '... got the right method'); +is($c->bar, 'Bar::bar', '... got the right method'); +is($c->baz, 'Baz::baz', '... got the right method'); +is($c->gorch, 'Gorch::gorch', '... got the right method'); + +is($c->foo_gorch, 'Foo::gorch', '... got the right method'); +is($c->baz_foo, 'Baz::foo', '... got the right method'); +is($c->baz_bar, 'Baz::bar', '... got the right method'); + +{ + package Splunk; + + use Moose::Role; + + sub baz { 'Splunk::baz' } + sub gorch { 'Splunk::gorch' } + + ::is(::exception { with 'Foo' }, undef, 'role to role application works'); + + package My::Class2; + + use Moose; + + ::is(::exception { with 'Splunk' }, undef, 'and the role can be consumed'); +} + +is(My::Class2->foo, 'Foo::foo', '... got the right method'); +is(My::Class2->bar, 'Foo::bar', '... got the right method'); +is(My::Class2->baz, 'Splunk::baz', '... got the right method'); +is(My::Class2->gorch, 'Splunk::gorch', '... got the right method'); + +done_testing; diff --git a/t/roles/more_role_edge_cases.t b/t/roles/more_role_edge_cases.t new file mode 100644 index 0000000..870c09f --- /dev/null +++ b/t/roles/more_role_edge_cases.t @@ -0,0 +1,255 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + # NOTE: + # this tests that repeated role + # composition will not cause + # a conflict between two methods + # which are actually the same anyway + + { + package RootA; + use Moose::Role; + + sub foo { "RootA::foo" } + + package SubAA; + use Moose::Role; + + with "RootA"; + + sub bar { "SubAA::bar" } + + package SubAB; + use Moose; + + ::is( ::exception { + with "SubAA", "RootA"; + }, undef, '... role was composed as expected' ); + } + + ok( SubAB->does("SubAA"), "does SubAA"); + ok( SubAB->does("RootA"), "does RootA"); + + isa_ok( my $i = SubAB->new, "SubAB" ); + + can_ok( $i, "bar" ); + is( $i->bar, "SubAA::bar", "... got thr right bar rv" ); + + can_ok( $i, "foo" ); + my $foo_rv; + is( exception { + $foo_rv = $i->foo; + }, undef, '... called foo successfully' ); + 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; + + ::is( ::exception { + with "SubBA"; + }, undef, '... 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; + is( exception { + $foo_rv = $i->foo + }, undef, '... called foo successfully' ); + is( $foo_rv, "RootB::foo", "foo rv" ); + is( $i->counter, 1, "after hook called" ); + + is( exception { $i->foo }, undef, '... called foo successfully (again)' ); + is( $i->counter, 2, "after hook called (again)" ); + + ok(SubBA->meta->has_method('foo'), '... this has the foo method'); + #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"; + + ::isnt( ::exception { + override foo => sub { "overridden" }; + }, undef, '... 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" ); + } +} + +done_testing; diff --git a/t/roles/new_meta_role.t b/t/roles/new_meta_role.t new file mode 100644 index 0000000..964c3eb --- /dev/null +++ b/t/roles/new_meta_role.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +do { + package My::Meta::Role; + use Moose; + BEGIN { extends 'Moose::Meta::Role' }; +}; + +do { + package My::Role; + use Moose::Role -metaclass => 'My::Meta::Role'; +}; + +is(My::Role->meta->meta->name, 'My::Meta::Role'); + +done_testing; diff --git a/t/roles/overloading_combine_to_class.t b/t/roles/overloading_combine_to_class.t new file mode 100644 index 0000000..e749248 --- /dev/null +++ b/t/roles/overloading_combine_to_class.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More 0.96; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::CombiningClass; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleWithoutOverloads )) { + + ok( + Overloading::CombiningClass->DOES($role), + "Overloading::CombiningClass does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::CombiningClass +); + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +OverloadingTests::test_overloading_for_package( + 'Overloading::CombiningClass'); + +done_testing(); diff --git a/t/roles/overloading_combine_to_instance.t b/t/roles/overloading_combine_to_instance.t new file mode 100644 index 0000000..73c4ebf --- /dev/null +++ b/t/roles/overloading_combine_to_instance.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::RoleWithOverloads; +use Overloading::RoleWithoutOverloads; + +{ + package MyClass; + use Moose; +} + +my $object = MyClass->new; + +Moose::Meta::Role->combine( + [ 'Overloading::RoleWithOverloads' => undef ], + [ 'Overloading::RoleWithoutOverloads' => undef ], +)->apply($object); + +OverloadingTests::test_overloading_for_package($_) + for 'Overloading::RoleWithOverloads', ref $object; + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +$object->message('foo'); + +OverloadingTests::test_overloading_for_object( + $object, + 'object with Overloading::RoleWithOverloads and Overloading::RoleWithoutOverloads combined and applied to instance' +); + +done_testing(); diff --git a/t/roles/overloading_combine_to_role.t b/t/roles/overloading_combine_to_role.t new file mode 100644 index 0000000..72eb9c4 --- /dev/null +++ b/t/roles/overloading_combine_to_role.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassWithCombiningRole; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleWithoutOverloads )) { + + ok( + Overloading::ClassWithCombiningRole->DOES($role), + "Overloading::ClassWithCombiningRole does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::ClassWithCombiningRole +); + +OverloadingTests::test_no_overloading_for_package( + 'Overloading::RoleWithoutOverloads'); + +OverloadingTests::test_overloading_for_package( + 'Overloading::ClassWithCombiningRole'); + +done_testing(); diff --git a/t/roles/overloading_composition_errors.t b/t/roles/overloading_composition_errors.t new file mode 100644 index 0000000..75e79ca --- /dev/null +++ b/t/roles/overloading_composition_errors.t @@ -0,0 +1,156 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Fatal; +use Test::Warnings; + +use lib 't/lib'; + +{ + package Role::HasFallback; + use Moose::Role; + + use overload + q{""} => '_stringify', + fallback => 1; + + sub _stringify { __PACKAGE__ } +} + +{ + package Role::NoFallback; + use Moose::Role; + + use overload + '0+' => '_numify', + fallback => 0; + + sub _numify { 42 } +} + +{ + package Class1; + use Moose; + ::like( + ::exception { with qw( Role::HasFallback Role::NoFallback ) }, + qr/\QWe have encountered an overloading conflict for the fallback during composition. This is a fatal error./, + 'exception from fallback conflict during role summation' + ); +} + +{ + package Role::NoOverloading; + use Moose::Role; + + sub foo { 42 } +} + +{ + package Class2; + use Moose; + ::like( + ::exception { with qw( Role::HasFallback Role::NoFallback Role::NoOverloading ) }, + qr/\QWe have encountered an overloading conflict for the fallback during composition. This is a fatal error./, + 'exception from fallback conflict during role summation including role without overloading' + ); +} + +{ + package Role::StringifiesViaSubref1; + use Moose::Role; + + use overload q{""} => sub { 'foo' }; +} + +{ + package Role::StringifiesViaSubref2; + use Moose::Role; + + use overload q{""} => sub { 'bar' }; +} + +{ + package Class3; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaSubref1 Role::StringifiesViaSubref2 ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different subref overloading conflict during role summation' + ); +} + +{ + package Class4; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaSubref1 Role::StringifiesViaSubref2 Role::NoOverloading ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different subref overloading conflict during role summation including role without overloading' + ); +} + +{ + package Role::StringifiesViaMethod1; + use Moose::Role; + + use overload q{""} => '_stringify1'; + sub _stringify1 { 'foo' } +} + +{ + package Role::StringifiesViaMethod2; + use Moose::Role; + + use overload q{""} => '_stringify2'; + sub _stringify2 { 'foo' } +} + +{ + package Class5; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaMethod1 Role::StringifiesViaMethod2 ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different method overloading conflict during role summation' + ); +} + +{ + package Class6; + use Moose; + ::like( + ::exception { with qw( Role::StringifiesViaMethod1 Role::StringifiesViaMethod2 Role::NoOverloading ) }, + qr/\QThe two roles both overload the '""' operator. This is a fatal error./, + 'exception when two roles with different method overloading conflict during role summation including role without overloading' + ); +} + +{ + { + package R1; + use Moose::Role; + + use overload '&{}' => 'as_code'; + + sub as_code { } + } + + { + package R2; + use Moose::Role; + with 'R1'; + } + + { + package C1; + use Moose; + ::is( + ::exception { with 'R1', 'R2' }, + undef, + 'no conflict when class consumes multiple roles with the same overloading' + ); + } +} + +done_testing(); diff --git a/t/roles/overloading_remove_attributes_bug.t b/t/roles/overloading_remove_attributes_bug.t new file mode 100644 index 0000000..15f6cc9 --- /dev/null +++ b/t/roles/overloading_remove_attributes_bug.t @@ -0,0 +1,36 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; + +use lib 't/lib'; + +use OverloadingTests; + +{ + package MyRole; + use Moose::Role; + + has foo => ( is => 'ro' ); + + # Note ordering here. If metaclass reinitialization nukes attributes, this + # breaks. + with 'Overloading::RoleWithOverloads'; +} + +{ + package MyClass; + use Moose; + + with 'MyRole'; +} + +my $object = MyClass->new( foo => 21, message => 'foo' ); + +OverloadingTests::test_overloading_for_object( $object, 'MyClass object' ); + +is( $object->foo(), 21, + 'foo attribute in MyClass is still present (from MyRole)' ); + +done_testing(); diff --git a/t/roles/overloading_to_class.t b/t/roles/overloading_to_class.t new file mode 100644 index 0000000..16972a7 --- /dev/null +++ b/t/roles/overloading_to_class.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassWithOneRole; + +ok( + Overloading::ClassWithOneRole->DOES('Overloading::RoleWithOverloads'), + 'Overloading::ClassWithOneRole consumed Overloading::RoleWithOverloads', +); + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::ClassWithOneRole +); + +OverloadingTests::test_overloading_for_object( + 'Overloading::ClassWithOneRole'); + +{ + package Role1; + use Moose::Role; + use overload + q{""} => '_role1_stringify', + q{+} => '_role1_plus', + fallback => 0; + sub _role1_stringify {__PACKAGE__} + sub _role1_plus {42} +} + +{ + package Class1; + use Moose; + use overload + q{""} => '_class1_stringify', + fallback => 1; + with 'Role1'; + sub _class1_stringify {__PACKAGE__} +} + +is( + Class1->meta->get_overload_fallback_value, + 1, + 'fallback setting for class overrides setting in composed role' +); + +is( + Class1->new . q{}, + 'Class1', + 'overload method for class overrides method in composed role' +); + +my $overload = Class1->meta->get_overloaded_operator(q{+}); +is( + $overload->original_overload->associated_metaclass->name, + 'Role1', + '+ overloading for Class1 originally came from Role1' +); + +done_testing(); diff --git a/t/roles/overloading_to_instance.t b/t/roles/overloading_to_instance.t new file mode 100644 index 0000000..7edbc22 --- /dev/null +++ b/t/roles/overloading_to_instance.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::RoleWithOverloads; + +{ + package MyClass; + use Moose; +} + +my $object = MyClass->new; +Overloading::RoleWithOverloads->meta->apply($object); + +OverloadingTests::test_overloading_for_package($_) + for 'Overloading::RoleWithOverloads', ref $object; + +$object->message('foo'); + +OverloadingTests::test_overloading_for_object( + $object, + 'object with Overloading::RoleWithOverloads applied to instance' +); + +done_testing(); diff --git a/t/roles/overloading_to_role.t b/t/roles/overloading_to_role.t new file mode 100644 index 0000000..f0fa326 --- /dev/null +++ b/t/roles/overloading_to_role.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::More 0.88; +use Test::Warnings; +use overload (); + +use lib 't/lib'; + +use OverloadingTests; +use Overloading::ClassConsumesRoleConsumesOverloads; + +for my $role ( + qw( Overloading::RoleWithOverloads Overloading::RoleConsumesOverloads )) { + + ok( + Overloading::ClassConsumesRoleConsumesOverloads->DOES($role), + "Overloading::ClassConsumesRoleConsumesOverloads does $role role" + ); +} + +OverloadingTests::test_overloading_for_package($_) for qw( + Overloading::RoleWithOverloads + Overloading::RoleConsumesOverloads + Overloading::ClassConsumesRoleConsumesOverloads +); + +OverloadingTests::test_overloading_for_object( + 'Overloading::ClassConsumesRoleConsumesOverloads'); + +# These tests failed on 5.18+ in MXRWO - the key issue was the lack of a +# "fallback" key being passed to overload.pm +{ + package MyRole1; + use Moose::Role; + use overload q{""} => '_stringify'; + sub _stringify {__PACKAGE__} +} + +{ + package MyRole2; + use Moose::Role; + with 'MyRole1'; +} + +{ + package Class1; + use Moose; + with 'MyRole2'; +} + +is( + Class1->new . q{}, + 'MyRole1', + 'stringification overloading is passed through all roles' +); + +done_testing(); diff --git a/t/roles/overriding.t b/t/roles/overriding.t new file mode 100644 index 0000000..dbaa443 --- /dev/null +++ b/t/roles/overriding.t @@ -0,0 +1,214 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + # test no conflicts here + package Role::A; + use Moose::Role; + + sub bar { 'Role::A::bar' } + + package Role::B; + use Moose::Role; + + sub xxy { 'Role::B::xxy' } + + package Role::C; + use Moose::Role; + + ::is( ::exception { + with qw(Role::A Role::B); # no conflict here + }, undef, "define role C" ); + + sub foo { 'Role::C::foo' } + sub zot { 'Role::C::zot' } + + package Class::A; + use Moose; + + ::is( ::exception { + with qw(Role::C); + }, undef, "define class A" ); + + sub zot { 'Class::A::zot' } +} + +can_ok( Class::A->new, qw(foo bar xxy zot) ); + +is( Class::A->new->foo, "Role::C::foo", "... got the right foo method" ); +is( Class::A->new->zot, "Class::A::zot", "... got the right zot method" ); +is( Class::A->new->bar, "Role::A::bar", "... got the right bar method" ); +is( Class::A->new->xxy, "Role::B::xxy", "... got the right xxy method" ); + +{ + # check that when a role is added to another role + # that the consumer's method shadows just like for classes. + + package Role::A::Shadow; + use Moose::Role; + + with 'Role::A'; + + sub bar { 'Role::A::Shadow::bar' } + + package Class::A::Shadow; + use Moose; + + ::is( ::exception { + with 'Role::A::Shadow'; + }, undef, '... did fufill the requirement of &bar method' ); +} + +can_ok( Class::A::Shadow->new, qw(bar) ); + +is( Class::A::Shadow->new->bar, 'Role::A::Shadow::bar', "... got the right bar method" ); + +{ + # check that when two roles are composed, they conflict + # but the composing role can resolve that conflict + + package Role::D; + use Moose::Role; + + sub foo { 'Role::D::foo' } + sub bar { 'Role::D::bar' } + + package Role::E; + use Moose::Role; + + sub foo { 'Role::E::foo' } + sub xxy { 'Role::E::xxy' } + + package Role::F; + use Moose::Role; + + ::is( ::exception { + with qw(Role::D Role::E); # conflict between 'foo's here + }, undef, "define role Role::F" ); + + sub foo { 'Role::F::foo' } + sub zot { 'Role::F::zot' } + + package Class::B; + use Moose; + + ::is( ::exception { + with qw(Role::F); + }, undef, "define class Class::B" ); + + sub zot { 'Class::B::zot' } +} + +can_ok( Class::B->new, qw(foo bar xxy zot) ); + +is( Class::B->new->foo, "Role::F::foo", "... got the &foo method okay" ); +is( Class::B->new->zot, "Class::B::zot", "... got the &zot method okay" ); +is( Class::B->new->bar, "Role::D::bar", "... got the &bar method okay" ); +is( Class::B->new->xxy, "Role::E::xxy", "... got the &xxy method okay" ); + +ok(!Role::F->meta->requires_method('foo'), '... Role::F fufilled the &foo requirement'); + +{ + # check that a conflict can be resolved + # by a role, but also new ones can be + # created just as easily ... + + package Role::D::And::E::NoConflict; + use Moose::Role; + + ::is( ::exception { + with qw(Role::D Role::E); # conflict between 'foo's here + }, undef, "... define role Role::D::And::E::NoConflict" ); + + sub foo { 'Role::D::And::E::NoConflict::foo' } # this overrides ... + + sub xxy { 'Role::D::And::E::NoConflict::xxy' } # and so do these ... + sub bar { 'Role::D::And::E::NoConflict::bar' } + +} + +ok(!Role::D::And::E::NoConflict->meta->requires_method('foo'), '... Role::D::And::E::NoConflict fufilled the &foo requirement'); +ok(!Role::D::And::E::NoConflict->meta->requires_method('xxy'), '... Role::D::And::E::NoConflict fulfilled the &xxy requirement'); +ok(!Role::D::And::E::NoConflict->meta->requires_method('bar'), '... Role::D::And::E::NoConflict fulfilled the &bar requirement'); + +{ + # conflict propagation + + package Role::H; + use Moose::Role; + + sub foo { 'Role::H::foo' } + sub bar { 'Role::H::bar' } + + package Role::J; + use Moose::Role; + + sub foo { 'Role::J::foo' } + sub xxy { 'Role::J::xxy' } + + package Role::I; + use Moose::Role; + + ::is( ::exception { + with qw(Role::J Role::H); # conflict between 'foo's here + }, undef, "define role Role::I" ); + + sub zot { 'Role::I::zot' } + sub zzy { 'Role::I::zzy' } + + package Class::C; + use Moose; + + ::like( ::exception { + with qw(Role::I); + }, qr/Due to a method name conflict in roles 'Role::H' and 'Role::J', the method 'foo' must be implemented or excluded by 'Class::C'/, "defining class Class::C fails" ); + + sub zot { 'Class::C::zot' } + + package Class::E; + use Moose; + + ::is( ::exception { + with qw(Role::I); + }, undef, "resolved with method" ); + + sub foo { 'Class::E::foo' } + sub zot { 'Class::E::zot' } +} + +can_ok( Class::E->new, qw(foo bar xxy zot) ); + +is( Class::E->new->foo, "Class::E::foo", "... got the right &foo method" ); +is( Class::E->new->zot, "Class::E::zot", "... got the right &zot method" ); +is( Class::E->new->bar, "Role::H::bar", "... got the right &bar method" ); +is( Class::E->new->xxy, "Role::J::xxy", "... got the right &xxy method" ); + +ok(Role::I->meta->requires_method('foo'), '... Role::I still have the &foo requirement'); + +{ + is( exception { + package Class::D; + use Moose; + + has foo => ( default => __PACKAGE__ . "::foo", is => "rw" ); + + sub zot { 'Class::D::zot' } + + with qw(Role::I); + + }, undef, "resolved with attr" ); + + can_ok( Class::D->new, qw(foo bar xxy zot) ); + is( eval { Class::D->new->bar }, "Role::H::bar", "bar" ); + is( eval { Class::D->new->zzy }, "Role::I::zzy", "zzy" ); + + is( eval { Class::D->new->foo }, "Class::D::foo", "foo" ); + is( eval { Class::D->new->zot }, "Class::D::zot", "zot" ); + +} + +done_testing; diff --git a/t/roles/reinitialize_anon_role.t b/t/roles/reinitialize_anon_role.t new file mode 100644 index 0000000..2554f2e --- /dev/null +++ b/t/roles/reinitialize_anon_role.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More; + +{ + package Role::Metarole; + use Moose::Role; +} + +my ($role2); +{ + my $role1 = Moose::Meta::Role->create_anon_role( + methods => { + foo => sub { }, + }, + ); + ok($role1->has_method('foo'), "role has method foo"); + $role2 = Moose::Util::MetaRole::apply_metaroles( + for => $role1->name, + role_metaroles => { role => ['Role::Metarole'] }, + ); + isnt($role1, $role2, "anon role was reinitialized"); + is($role1->name, $role2->name, "but it's the same anon role"); + is_deeply([sort $role2->get_method_list], ['foo', 'meta'], + "has the right methods"); +} +is_deeply([sort $role2->get_method_list], ['foo', 'meta'], + "still has the right methods"); + +done_testing; diff --git a/t/roles/role.t b/t/roles/role.t new file mode 100644 index 0000000..083e5ac --- /dev/null +++ b/t/roles/role.t @@ -0,0 +1,154 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +NOTE: + +Should we be testing here that the has & override +are injecting their methods correctly? In other +words, should 'has_method' return true for them? + +=cut + +{ + package FooRole; + use Moose::Role; + + our $VERSION = '0.01'; + + has 'bar' => (is => 'rw', isa => 'Foo'); + has 'baz' => (is => 'ro'); + + 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" }; + + ::isnt( ::exception { extends() }, undef, '... extends() is not supported' ); + ::isnt( ::exception { augment() }, undef, '... augment() is not supported' ); + ::isnt( ::exception { inner() }, undef, '... inner() is not supported' ); + + no Moose::Role; +} + +my $foo_role = FooRole->meta; +isa_ok($foo_role, 'Moose::Meta::Role'); +isa_ok($foo_role, 'Class::MOP::Module'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); + +isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); + +ok($foo_role->has_method('boo'), '... FooRole has the boo method'); +is($foo_role->get_method('boo')->body, \&FooRole::boo, '... FooRole got the boo method'); + +isa_ok($foo_role->get_method('boo'), 'Moose::Meta::Role::Method'); + +is_deeply( + [ sort $foo_role->get_method_list() ], + [ 'boo', 'foo', 'meta' ], + '... got the right method list'); + +ok(FooRole->can('foo'), "locally defined methods are still there"); +ok(!FooRole->can('has'), "sugar was unimported"); + +# attributes ... + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +my $bar_attr = $foo_role->get_attribute('bar'); +is($bar_attr->{is}, 'rw', + 'bar attribute is rw'); +is($bar_attr->{isa}, 'Foo', + 'bar attribute isa Foo'); +is(ref($bar_attr->{definition_context}), 'HASH', + 'bar\'s definition context is a hash'); +is($bar_attr->{definition_context}->{package}, 'FooRole', + 'bar was defined in FooRole'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +my $baz_attr = $foo_role->get_attribute('baz'); +is($baz_attr->{is}, 'ro', + 'baz attribute is ro'); +is(ref($baz_attr->{definition_context}), 'HASH', + 'bar\'s definition context is a hash'); +is($baz_attr->{definition_context}->{package}, 'FooRole', + 'baz was defined in FooRole'); + +# 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'); + +done_testing; diff --git a/t/roles/role_attr_application.t b/t/roles/role_attr_application.t new file mode 100644 index 0000000..05720e9 --- /dev/null +++ b/t/roles/role_attr_application.t @@ -0,0 +1,291 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use Moose::Util qw( does_role ); + +{ + package Foo::Meta::Attribute; + use Moose::Role; +} + +{ + package Foo::Meta::Attribute2; + use Moose::Role; +} + +{ + package Foo::Role; + use Moose::Role; + + has foo => (is => 'ro'); +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Foo::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Foo::Meta::Attribute2'] }, + ); + with 'Foo::Role'; + + has bar => (is => 'ro'); +} + +ok(Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the metarole applied"); +ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the role metarole defined in the class applied"); + +{ + package Bar::Meta::Attribute; + use Moose::Role; +} + +{ + package Bar::Meta::Attribute2; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Bar::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Bar::Meta::Attribute2'] }, + ); + + has foo => (is => 'ro'); +} + +{ + package Bar; + use Moose; + with 'Bar::Role'; + + has bar => (is => 'ro'); +} + +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'), "attrs defined in the class don't get the class metarole from the role applied"); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); +ok(!Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); + +{ + package Baz::Meta::Attribute; + use Moose::Role; +} + +{ + package Baz::Meta::Attribute2; + use Moose::Role; +} + +{ + package Baz::Role; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, + ); + + has foo => (is => 'ro'); +} + +{ + package Baz; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, + role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, + ); + with 'Baz::Role'; + + has bar => (is => 'ro'); +} + +ok(Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); +ok(!Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); +ok(Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); +ok(!Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); + +{ + package Accessor::Modifying::Role; + use Moose::Role; + + around _process_options => sub { + my $orig = shift; + my $self = shift; + my ($name, $params) = @_; + $self->$orig(@_); + $params->{reader} .= '_foo'; + }; +} + +{ + package Plain::Role; + use Moose::Role; + + has foo => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + package Class::With::Trait; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + attribute => ['Accessor::Modifying::Role'], + }, + ); + with 'Plain::Role'; + + has bar => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + can_ok('Class::With::Trait', 'foo'); + can_ok('Class::With::Trait', 'bar_foo'); +} + +{ + package Role::With::Trait; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Accessor::Modifying::Role'], + }, + ); + with 'Plain::Role'; + + has foo => ( + is => 'ro', + isa => 'Str', + ); + + sub foo_test { + my $self = shift; + return $self->can('foo_foo'); + } +} + +{ + package Class::With::Role::With::Trait; + use Moose; + with 'Role::With::Trait'; + + has bar => ( + is => 'ro', + isa => 'Str', + ); + + sub bar_test { + my $self = shift; + return $self->can('bar'); + } +} + +{ + can_ok('Class::With::Role::With::Trait', 'foo_foo'); + can_ok('Class::With::Role::With::Trait', 'bar'); +} + +{ + package Quux::Meta::Role::Attribute; + use Moose::Role; +} + +{ + package Quux::Role1; + use Moose::Role; + + has foo => (traits => ['Quux::Meta::Role::Attribute'], is => 'ro'); + has baz => (is => 'ro'); +} + +{ + package Quux::Role2; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Quux::Meta::Role::Attribute'] + }, + ); + + has bar => (is => 'ro'); +} + +{ + package Quux; + use Moose; + with 'Quux::Role1', 'Quux::Role2'; +} + +{ + my $foo = Quux->meta->get_attribute('foo'); + does_ok($foo, 'Quux::Meta::Role::Attribute', + "individual attribute trait applied correctly"); + + my $baz = Quux->meta->get_attribute('baz'); + ok(! does_role($baz, 'Quux::Meta::Role::Attribute'), + "applied_attribute traits do not end up applying to attributes from other roles during composition"); + + my $bar = Quux->meta->get_attribute('bar'); + does_ok($bar, 'Quux::Meta::Role::Attribute', + "attribute metarole applied correctly"); +} + +{ + package HasMeta; + use Moose::Role; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + role_metaroles => { + applied_attribute => ['Quux::Meta::Role::Attribute'] + }, + ); + + has foo => (is => 'ro'); +} + +{ + package NoMeta; + use Moose::Role; + + with 'HasMeta'; + + has bar => (is => 'ro'); +} + +{ + package ConsumesBoth; + use Moose; + with 'HasMeta', 'NoMeta'; +} + +{ + my $foo = ConsumesBoth->meta->get_attribute('foo'); + does_ok($foo, 'Quux::Meta::Role::Attribute', + 'applied_attribute traits are preserved when one role consumes another'); + + my $bar = ConsumesBoth->meta->get_attribute('bar'); + ok(! does_role($bar, 'Quux::Meta::Role::Attribute'), + "applied_attribute traits do not spill over from consumed role"); +} + + + +done_testing; diff --git a/t/roles/role_attribute_conflict.t b/t/roles/role_attribute_conflict.t new file mode 100644 index 0000000..d4ad4c5 --- /dev/null +++ b/t/roles/role_attribute_conflict.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package My::Role1; + use Moose::Role; + + has foo => ( + is => 'ro', + ); + +} + +{ + package My::Role2; + use Moose::Role; + + has foo => ( + is => 'ro', + ); + + ::like( ::exception { with 'My::Role1' }, qr/attribute conflict.+My::Role2.+foo/, 'attribute conflict when composing one role into another' ); +} + +done_testing; diff --git a/t/roles/role_attrs.t b/t/roles/role_attrs.t new file mode 100644 index 0000000..6c1ea8b --- /dev/null +++ b/t/roles/role_attrs.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Role; +use Moose::Util; + +my $role1 = Moose::Meta::Role->initialize('Foo'); +$role1->add_attribute( foo => ( is => 'ro' ) ); + +ok( $role1->has_attribute('foo'), 'Foo role has a foo attribute' ); + +my $foo_attr = $role1->get_attribute('foo'); +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is Foo role' +); + +isa_ok( + $foo_attr->attribute_for_class('Moose::Meta::Attribute'), + 'Moose::Meta::Attribute', + 'attribute returned by ->attribute_for_class' +); + +my $role2 = Moose::Meta::Role->initialize('Bar'); +$role1->apply($role2); + +ok( $role2->has_attribute('foo'), 'Bar role has a foo attribute' ); + +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is still Foo role' +); + +isa_ok( + $foo_attr->attribute_for_class('Moose::Meta::Attribute'), + 'Moose::Meta::Attribute', + 'attribute returned by ->attribute_for_class' +); + +my $role3 = Moose::Meta::Role->initialize('Baz'); +my $combined = Moose::Meta::Role->combine( [ $role1->name ], [ $role3->name ] ); + +ok( $combined->has_attribute('foo'), 'combined role has a foo attribute' ); + +is( + $foo_attr->associated_role->name, 'Foo', + 'associated_role for foo attr is still Foo role' +); + +done_testing; diff --git a/t/roles/role_compose_requires.t b/t/roles/role_compose_requires.t new file mode 100644 index 0000000..06337ff --- /dev/null +++ b/t/roles/role_compose_requires.t @@ -0,0 +1,132 @@ +use strict; +use warnings; + +# See https://rt.cpan.org/Ticket/Display.html?id=46347 + +use Test::More; +use Test::Fatal; + +{ + package My::Role1; + use Moose::Role; + requires 'test_output'; +} + +{ + package My::Role2; + use Moose::Role; + has test_output => ( is => 'rw' ); + with 'My::Role1'; +} + +{ + package My::Role3; + use Moose::Role; + sub test_output { } + with 'My::Role1'; +} + +{ + package My::Role4; + use Moose::Role; + has test_output => ( is => 'rw' ); +} + +{ + package My::Role5; + use Moose::Role; + sub test_output { } +} + +{ + package My::Base1; + use Moose; + has test_output => ( is => 'rw' ); +} + +{ + package My::Base2; + use Moose; + sub test_output { } +} + +# Roles providing attributes/methods should satisfy requires() of other +# roles they consume. +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test1; use Moose; with 'My::Role2'; }, undef, 'role2(provides attribute) consumes role1' ); +} + +is( exception { package My::Test2; use Moose; with 'My::Role3'; }, undef, 'role3(provides method) consumes role1' ); + +# As I understand the design, Roles composed in the same with() statement +# should NOT demonstrate ordering dependency. Alter these tests if that +# assumption is false. -Vince Veselosky +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test3; use Moose; with 'My::Role4', 'My::Role1'; }, undef, 'class consumes role4(provides attribute), role1' ); +} + +{ + local $TODO = "role attributes don't satisfy method requirements"; + is( exception { package My::Test4; use Moose; with 'My::Role1', 'My::Role4'; }, undef, 'class consumes role1, role4(provides attribute)' ); +} + +is( exception { package My::Test5; use Moose; with 'My::Role5', 'My::Role1'; }, undef, 'class consumes role5(provides method), role1' ); + +is( exception { package My::Test6; use Moose; with 'My::Role1', 'My::Role5'; }, undef, 'class consumes role1, role5(provides method)' ); + +# Inherited methods/attributes should satisfy requires(), as long as +# extends() comes first in code order. +is( exception { + package My::Test7; + use Moose; + extends 'My::Base1'; + with 'My::Role1'; +}, undef, 'class extends base1(provides attribute), consumes role1' ); + +is( exception { + package My::Test8; + use Moose; + extends 'My::Base2'; + with 'My::Role1'; +}, undef, 'class extends base2(provides method), consumes role1' ); + +# Attributes/methods implemented in class should satisfy requires() +is( exception { + + package My::Test9; + use Moose; + has 'test_output', is => 'rw'; + with 'My::Role1'; +}, undef, 'class provides attribute, consumes role1' ); + +is( exception { + + package My::Test10; + use Moose; + sub test_output { } + with 'My::Role1'; +}, undef, 'class provides method, consumes role1' ); + +# Roles composed in separate with() statements SHOULD demonstrate ordering +# dependency. See comment with tests 3-6 above. +is( exception { + package My::Test11; + use Moose; + with 'My::Role4'; + with 'My::Role1'; +}, undef, 'class consumes role4(provides attribute); consumes role1' ); + +isnt( exception { package My::Test12; use Moose; with 'My::Role1'; with 'My::Role4'; }, undef, 'class consumes role1; consumes role4(provides attribute)' ); + +is( exception { + package My::Test13; + use Moose; + with 'My::Role5'; + with 'My::Role1'; +}, undef, 'class consumes role5(provides method); consumes role1' ); + +isnt( exception { package My::Test14; use Moose; with 'My::Role1'; with 'My::Role5'; }, undef, 'class consumes role1; consumes role5(provides method)' ); + +done_testing; diff --git a/t/roles/role_composite.t b/t/roles/role_composite.t new file mode 100644 index 0000000..f3c52aa --- /dev/null +++ b/t/roles/role_composite.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + package Role::Bar; + use Moose::Role; + + package Role::Baz; + use Moose::Role; + + package Role::Gorch; + use Moose::Role; +} + +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::Baz->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar|Role::Baz', '... got the composite role name'); + + is_deeply($c->get_roles, [ + Role::Foo->meta, + Role::Bar->meta, + Role::Baz->meta, + ], '... got the right roles'); + + ok($c->does_role($_), '... our composite does the role ' . $_) + for qw( + Role::Foo + Role::Bar + Role::Baz + ); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this composed okay' ); + + ok(!$c->is_anon, '... composite is not anonymous'); + + ##... now nest 'em + { + my $c2 = Moose::Meta::Role::Composite->new( + roles => [ + $c, + Role::Gorch->meta, + ] + ); + isa_ok($c2, 'Moose::Meta::Role::Composite'); + + is($c2->name, 'Role::Foo|Role::Bar|Role::Baz|Role::Gorch', '... got the composite role name'); + + is_deeply($c2->get_roles, [ + $c, + Role::Gorch->meta, + ], '... got the right roles'); + + ok($c2->does_role($_), '... our composite does the role ' . $_) + for qw( + Role::Foo + Role::Bar + Role::Baz + Role::Gorch + ); + + ok(!$c2->is_anon, '... composite is not anonymous'); + } +} + +done_testing; diff --git a/t/roles/role_composite_exclusion.t b/t/roles/role_composite_exclusion.t new file mode 100644 index 0000000..ed44308 --- /dev/null +++ b/t/roles/role_composite_exclusion.t @@ -0,0 +1,107 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + package Role::Bar; + use Moose::Role; + + package Role::ExcludesFoo; + use Moose::Role; + excludes 'Role::Foo'; + + package Role::DoesExcludesFoo; + use Moose::Role; + with 'Role::ExcludesFoo'; + + package Role::DoesFoo; + use Moose::Role; + with 'Role::Foo'; +} + +ok(Role::ExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); +ok(Role::DoesExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); + +# test simple exclusion +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ExcludesFoo->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test no conflicts +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives as expected' ); +} + +# test no conflicts w/exclusion +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Bar->meta, + Role::ExcludesFoo->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives as expected' ); + + is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles'); +} + + +# test conflict with an "inherited" exclusion +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::DoesExcludesFoo->meta, + ] + ) + ); + +}, undef, '... this fails as expected' ); + +# test conflict with an "inherited" exclusion of an "inherited" role +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::DoesFoo->meta, + Role::DoesExcludesFoo->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +done_testing; diff --git a/t/roles/role_composition_attributes.t b/t/roles/role_composition_attributes.t new file mode 100644 index 0000000..f11a0c5 --- /dev/null +++ b/t/roles/role_composition_attributes.t @@ -0,0 +1,93 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + has 'foo' => (is => 'rw'); + + package Role::Bar; + use Moose::Role; + has 'bar' => (is => 'rw'); + + package Role::FooConflict; + use Moose::Role; + has 'foo' => (is => 'rw'); + + package Role::BarConflict; + use Moose::Role; + has 'bar' => (is => 'rw'); + + package Role::AnotherFooConflict; + use Moose::Role; + with 'Role::FooConflict'; +} + +# test simple attributes +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_attribute_list ], + [ 'bar', 'foo' ], + '... got the right list of attributes' + ); +} + +# test simple conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test complex conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + Role::BarConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test simple conflict +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::AnotherFooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +done_testing; diff --git a/t/roles/role_composition_conflict_detection.t b/t/roles/role_composition_conflict_detection.t new file mode 100644 index 0000000..d2b693a --- /dev/null +++ b/t/roles/role_composition_conflict_detection.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; +use Moose::Util qw( find_meta ); + +{ + package RoleA; + use Moose::Role; + + sub foo { 42 } +} + +{ + package RoleB; + use Moose::Role; + + with 'RoleA'; +} + +{ + package RoleC; + use Moose::Role; + + sub foo { 84 } +} + +{ + my $composite + = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } + qw( RoleA RoleB RoleC ) ); + ok( $composite->requires_method('foo'), 'Composite of [ABC] requires a foo method' ); + ok( ! $composite->has_method('foo'), 'Composite of [ABC] does not also have a foo method' ); +} + +{ + my $composite + = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } + qw( RoleA RoleC RoleB ) ); + ok( $composite->requires_method('foo'), 'Composite of [ACB] requires a foo method' ); + ok( ! $composite->has_method('foo'), 'Composite of [ACB] does not also have a foo method' ); +} + +done_testing; diff --git a/t/roles/role_composition_errors.t b/t/roles/role_composition_errors.t new file mode 100644 index 0000000..8fe9178 --- /dev/null +++ b/t/roles/role_composition_errors.t @@ -0,0 +1,141 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Foo::Role; + use Moose::Role; + + requires 'foo'; +} + +is_deeply( + [ sort Foo::Role->meta->get_required_method_list ], + ['foo'], + '... the Foo::Role has a required method (foo)' +); + +# classes which does not implement required method +{ + + package Foo::Class; + use Moose; + + ::isnt( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Foo::Class' ); +} + +# class which does implement required method +{ + + package Bar::Class; + use Moose; + + ::isnt( ::exception { with('Foo::Class') }, undef, '... cannot consume a class, it must be a role' ); + ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Class' ); + + sub foo {'Bar::Class::foo'} +} + +# role which does implement required method +{ + + package Bar::Role; + use Moose::Role; + + ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Role' ); + + sub foo {'Bar::Role::foo'} +} + +is_deeply( + [ sort Bar::Role->meta->get_required_method_list ], + [], + '... the Bar::Role has not inherited the required method from Foo::Role' +); + +# role which does not implement required method +{ + + package Baz::Role; + use Moose::Role; + + ::is( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Baz::Role' ); +} + +is_deeply( + [ sort Baz::Role->meta->get_required_method_list ], + ['foo'], + '... the Baz::Role has inherited the required method from Foo::Role' +); + +# classes which does not implement required method +{ + + package Baz::Class; + use Moose; + + ::isnt( ::exception { with('Baz::Role') }, undef, '... no foo method implemented by Baz::Class2' ); +} + +# class which does implement required method +{ + + package Baz::Class2; + use Moose; + + ::is( ::exception { with('Baz::Role') }, undef, '... has a foo method implemented by Baz::Class2' ); + + sub foo {'Baz::Class2::foo'} +} + + +{ + package Quux::Role; + use Moose::Role; + + requires qw( meth1 meth2 meth3 meth4 ); +} + +# RT #41119 +{ + + package Quux::Class; + use Moose; + + ::like( ::exception { with('Quux::Role') }, qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); +} + +{ + package Quux::Class2; + use Moose; + + sub meth1 { } + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class2'/, 'exception mentions all the missing required methods at once, but not the one that exists' ); +} + +{ + package Quux::Class3; + use Moose; + + has 'meth1' => ( is => 'ro' ); + has 'meth2' => ( is => 'ro' ); + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'/, 'exception mentions all the missing methods at once, but not the accessors' ); +} + +{ + package Quux::Class4; + use Moose; + + sub meth1 { } + has 'meth2' => ( is => 'ro' ); + + ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'/, 'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists' ); +} + +done_testing; diff --git a/t/roles/role_composition_method_mods.t b/t/roles/role_composition_method_mods.t new file mode 100644 index 0000000..8f9e4fc --- /dev/null +++ b/t/roles/role_composition_method_mods.t @@ -0,0 +1,86 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + before foo => sub { 'Role::Foo::foo' }; + around foo => sub { 'Role::Foo::foo' }; + after foo => sub { 'Role::Foo::foo' }; + around baz => sub { [ 'Role::Foo', @{shift->(@_)} ] }; + + package Role::Bar; + use Moose::Role; + + before bar => sub { 'Role::Bar::bar' }; + around bar => sub { 'Role::Bar::bar' }; + after bar => sub { 'Role::Bar::bar' }; + + package Role::Baz; + use Moose::Role; + + with 'Role::Foo'; + around baz => sub { [ 'Role::Baz', @{shift->(@_)} ] }; + +} + +{ + package Class::FooBar; + use Moose; + + with 'Role::Baz'; + sub foo { 'placeholder' } + sub baz { ['Class::FooBar'] } +} + +#test modifier call order +{ + is_deeply( + Class::FooBar->baz, + ['Role::Baz','Role::Foo','Class::FooBar'] + ); +} + +# test simple overrides +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_modifier_list('before') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_method_modifier_list('after') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_method_modifier_list('around') ], + [ 'bar', 'baz', 'foo' ], + '... got the right list of methods' + ); +} + +done_testing; diff --git a/t/roles/role_composition_methods.t b/t/roles/role_composition_methods.t new file mode 100644 index 0000000..62d70c8 --- /dev/null +++ b/t/roles/role_composition_methods.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + sub foo { 'Role::Foo::foo' } + + package Role::Bar; + use Moose::Role; + + sub bar { 'Role::Bar::bar' } + + package Role::FooConflict; + use Moose::Role; + + sub foo { 'Role::FooConflict::foo' } + + package Role::BarConflict; + use Moose::Role; + + sub bar { 'Role::BarConflict::bar' } + + package Role::AnotherFooConflict; + use Moose::Role; + with 'Role::FooConflict'; + + sub baz { 'Role::AnotherFooConflict::baz' } +} + +# test simple attributes +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); +} + +# test simple conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'foo' ], + '... got the right list of required methods' + ); +} + +# test complex conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + Role::BarConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar', 'foo' ], + '... got the right list of required methods' + ); +} + +# test simple conflict +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::AnotherFooConflict->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_method_list ], + [ 'baz' ], + '... got the right list of methods' + ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'foo' ], + '... got the right list of required methods' + ); +} + +done_testing; diff --git a/t/roles/role_composition_override.t b/t/roles/role_composition_override.t new file mode 100644 index 0000000..dcabe76 --- /dev/null +++ b/t/roles/role_composition_override.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + + override foo => sub { 'Role::Foo::foo' }; + + package Role::Bar; + use Moose::Role; + + override bar => sub { 'Role::Bar::bar' }; + + package Role::FooConflict; + use Moose::Role; + + override foo => sub { 'Role::FooConflict::foo' }; + + package Role::FooMethodConflict; + use Moose::Role; + + sub foo { 'Role::FooConflict::foo' } + + package Role::BarMethodConflict; + use Moose::Role; + + sub bar { 'Role::BarConflict::bar' } +} + +# test simple overrides +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this lives ok' ); + + is_deeply( + [ sort $c->get_method_modifier_list('override') ], + [ 'bar', 'foo' ], + '... got the right list of methods' + ); +} + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::FooMethodConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + + +# test simple overrides w/ conflicts +isnt( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply( + Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + Role::FooMethodConflict->meta, + ] + ) + ); +}, undef, '... this fails as expected' ); + +{ + { + package Foo; + use Moose::Role; + + override test => sub { print "override test in Foo" }; + } + + my $exception = exception { + { + package Bar; + use Moose::Role; + + override test => sub { print "override test in Bar" }; + with 'Foo'; + } + }; + + like( + $exception, + qr/\QRole 'Foo' has encountered an 'override' method conflict during composition (Two 'override' methods of the same name encountered). This is a fatal error./, + "Foo & Bar, both roles are overriding test method"); +} + +{ + { + package Role::A; + use Moose::Role; + + override a_method => sub { "a method in A" }; + } + + { + package Role::B; + use Moose::Role; + with 'Role::A'; + } + + { + package Role::C; + use Moose::Role; + with 'Role::A' + } + + my $exception = exception { + { + package Role::D; + use Moose::Role; + with 'Role::B'; + with 'Role::C'; + } + }; + + is( $exception, undef, "this works fine"); +} + +done_testing; diff --git a/t/roles/role_composition_req_methods.t b/t/roles/role_composition_req_methods.t new file mode 100644 index 0000000..7209aa9 --- /dev/null +++ b/t/roles/role_composition_req_methods.t @@ -0,0 +1,123 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Meta::Role::Application::RoleSummation; +use Moose::Meta::Role::Composite; + +{ + package Role::Foo; + use Moose::Role; + requires 'foo'; + + package Role::Bar; + use Moose::Role; + requires 'bar'; + + package Role::ProvidesFoo; + use Moose::Role; + sub foo { 'Role::ProvidesFoo::foo' } + + package Role::ProvidesBar; + use Moose::Role; + sub bar { 'Role::ProvidesBar::bar' } +} + +# test simple requirement +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar', 'foo' ], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ 'bar' ], + '... got the right list of required methods' + ); +} + +# test requirement satisfied +{ + my $c = Moose::Meta::Role::Composite->new( + roles => [ + Role::Foo->meta, + Role::ProvidesFoo->meta, + Role::ProvidesBar->meta, + Role::Bar->meta, + ] + ); + isa_ok($c, 'Moose::Meta::Role::Composite'); + + is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name'); + + is( exception { + Moose::Meta::Role::Application::RoleSummation->new->apply($c); + }, undef, '... this succeeds as expected' ); + + is_deeply( + [ sort $c->get_required_method_list ], + [ ], + '... got the right list of required methods' + ); +} + +done_testing; diff --git a/t/roles/role_conflict_detection.t b/t/roles/role_conflict_detection.t new file mode 100644 index 0000000..0f80f55 --- /dev/null +++ b/t/roles/role_conflict_detection.t @@ -0,0 +1,595 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +Mutually recursive roles. + +=cut + +{ + package Role::Foo; + use Moose::Role; + + requires 'foo'; + + sub bar { 'Role::Foo::bar' } + + package Role::Bar; + use Moose::Role; + + requires 'bar'; + + sub foo { 'Role::Bar::foo' } +} + +{ + package My::Test1; + use Moose; + + ::is( ::exception { + with 'Role::Foo', 'Role::Bar'; + }, undef, '... our mutually recursive roles combine okay' ); + + package My::Test2; + use Moose; + + ::is( ::exception { + with 'Role::Bar', 'Role::Foo'; + }, undef, '... our mutually recursive roles combine okay (no matter what order)' ); +} + +my $test1 = My::Test1->new; +isa_ok($test1, 'My::Test1'); + +ok($test1->does('Role::Foo'), '... $test1 does Role::Foo'); +ok($test1->does('Role::Bar'), '... $test1 does Role::Bar'); + +can_ok($test1, 'foo'); +can_ok($test1, 'bar'); + +is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked'); +is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked'); + +my $test2 = My::Test2->new; +isa_ok($test2, 'My::Test2'); + +ok($test2->does('Role::Foo'), '... $test2 does Role::Foo'); +ok($test2->does('Role::Bar'), '... $test2 does Role::Bar'); + +can_ok($test2, 'foo'); +can_ok($test2, 'bar'); + +is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked'); +is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked'); + +# check some meta-stuff + +ok(Role::Foo->meta->has_method('bar'), '... it still has the bar method'); +ok(Role::Foo->meta->requires_method('foo'), '... it still has the required foo method'); + +ok(Role::Bar->meta->has_method('foo'), '... it still has the foo method'); +ok(Role::Bar->meta->requires_method('bar'), '... it still has the required bar method'); + +=pod + +Role method conflicts + +=cut + +{ + package Role::Bling; + use Moose::Role; + + sub bling { 'Role::Bling::bling' } + + package Role::Bling::Bling; + use Moose::Role; + + sub bling { 'Role::Bling::Bling::bling' } +} + +{ + package My::Test3; + use Moose; + + ::like( ::exception { + with 'Role::Bling', 'Role::Bling::Bling'; + }, qr/Due to a method name conflict in roles 'Role::Bling' and 'Role::Bling::Bling', the method 'bling' must be implemented or excluded by 'My::Test3'/, '... role methods conflict and method was required' ); + + package My::Test4; + use Moose; + + ::is( ::exception { + with 'Role::Bling'; + with 'Role::Bling::Bling'; + }, undef, '... role methods didnt conflict when manually combined' ); + + package My::Test5; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling'; + with 'Role::Bling'; + }, undef, '... role methods didnt conflict when manually combined (in opposite order)' ); + + package My::Test6; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', 'Role::Bling'; + }, undef, '... role methods didnt conflict when manually resolved' ); + + sub bling { 'My::Test6::bling' } + + package My::Test7; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', { -excludes => ['bling'] }, 'Role::Bling'; + }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded' ); + + package My::Test8; + use Moose; + + ::is( ::exception { + with 'Role::Bling::Bling', { -excludes => ['bling'], -alias => { bling => 'bling_bling' } }, 'Role::Bling'; + }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded and aliased' ); +} + +ok(!My::Test3->meta->has_method('bling'), '... we didnt get any methods in the conflict'); +ok(My::Test4->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test7->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test8->meta->has_method('bling'), '... we did get the method when manually dealt with'); +ok(My::Test8->meta->has_method('bling_bling'), '... we did get the aliased method too'); + +ok(!My::Test3->does('Role::Bling'), '... our class does() the correct roles'); +ok(!My::Test3->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test4->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test4->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test5->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test5->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test6->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test6->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test7->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test7->does('Role::Bling::Bling'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Bling'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Bling::Bling'), '... our class does() the correct roles'); + +is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added'); +is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added'); +is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method'); +is(My::Test7->bling, 'Role::Bling::bling', '... and we got the non-excluded method'); +is(My::Test8->bling, 'Role::Bling::bling', '... and we got the non-excluded/aliased method'); +is(My::Test8->bling_bling, 'Role::Bling::Bling::bling', '... and the aliased method comes from the correct role'); + +# check how this affects role compostion + +{ + package Role::Bling::Bling::Bling; + use Moose::Role; + + with 'Role::Bling::Bling'; + + sub bling { 'Role::Bling::Bling::Bling::bling' } +} + +ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling'); +ok(Role::Bling::Bling->meta->does_role('Role::Bling::Bling'), '... our role correctly does() the other role'); +ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... dont have the bling method in Role::Bling::Bling::Bling'); +is(Role::Bling::Bling::Bling->meta->get_method('bling')->(), + 'Role::Bling::Bling::Bling::bling', + '... still got the bling method in Role::Bling::Bling::Bling'); + + +=pod + +Role attribute conflicts + +=cut + +{ + package Role::Boo; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost'); + + package Role::Boo::Hoo; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost'); +} + +{ + package My::Test7; + use Moose; + + ::like( ::exception { + with 'Role::Boo', 'Role::Boo::Hoo'; + }, qr/We have encountered an attribute conflict.+ghost/ ); + + package My::Test8; + use Moose; + + ::is( ::exception { + with 'Role::Boo'; + with 'Role::Boo::Hoo'; + }, undef, '... role attrs didnt conflict when manually combined' ); + + package My::Test9; + use Moose; + + ::is( ::exception { + with 'Role::Boo::Hoo'; + with 'Role::Boo'; + }, undef, '... role attrs didnt conflict when manually combined' ); + + package My::Test10; + use Moose; + + has 'ghost' => (is => 'ro', default => 'My::Test10::ghost'); + + ::like( ::exception { + with 'Role::Boo', 'Role::Boo::Hoo'; + }, qr/We have encountered an attribute conflict/, '... role attrs conflict and cannot be manually disambiguted' ); + +} + +ok(!My::Test7->meta->has_attribute('ghost'), '... we didnt get any attributes in the conflict'); +ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); +ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); +ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)'); + +ok(!My::Test7->does('Role::Boo'), '... our class does() the correct roles'); +ok(!My::Test7->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Boo'), '... our class does() the correct roles'); +ok(My::Test8->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(My::Test9->does('Role::Boo'), '... our class does() the correct roles'); +ok(My::Test9->does('Role::Boo::Hoo'), '... our class does() the correct roles'); +ok(!My::Test10->does('Role::Boo'), '... our class does() the correct roles'); +ok(!My::Test10->does('Role::Boo::Hoo'), '... our class does() the correct roles'); + +can_ok('My::Test8', 'ghost'); +can_ok('My::Test9', 'ghost'); +can_ok('My::Test10', 'ghost'); + +is(My::Test8->new->ghost, 'Role::Boo::ghost', '... got the expected default attr value'); +is(My::Test9->new->ghost, 'Role::Boo::Hoo::ghost', '... got the expected default attr value'); +is(My::Test10->new->ghost, 'My::Test10::ghost', '... got the expected default attr value'); + +=pod + +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'; + + ::is( ::exception { + with 'Role::Truth'; + }, undef, '... composed the role with override okay' ); + + package My::Test12; + use Moose; + + extends 'My::Test::Base'; + + ::is( ::exception { + with 'Role::Plot'; + }, undef, '... composed the role with override okay' ); + + package My::Test13; + use Moose; + + ::isnt( ::exception { + with 'Role::Plot'; + }, undef, '... cannot compose it because we have no superclass' ); + + package My::Test14; + use Moose; + + extends 'My::Test::Base'; + + ::like( ::exception { + 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; + + ::like( ::exception { + 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'); + +# Ovid's test case from rt.cpan.org #44 +{ + package Role1; + use Moose::Role; + + sub foo {} +} +{ + package Role2; + use Moose::Role; + + sub foo {} +} +{ + package Conflicts; + use Moose; + + ::like( ::exception { + with qw(Role1 Role2); + }, qr/Due to a method name conflict in roles 'Role1' and 'Role2', the method 'foo' must be implemented or excluded by 'Conflicts'/ ); +} + +=pod + +Role conflicts between attributes and methods + +[15:23] <kolibrie> when class defines method and role defines method, class wins +[15:24] <kolibrie> when class 'has' method and role defines method, class wins +[15:24] <kolibrie> when class defines method and role 'has' method, role wins +[15:24] <kolibrie> when class 'has' method and role 'has' method, role wins +[15:24] <kolibrie> which means when class 'has' method and two roles 'has' method, no tiebreak is detected +[15:24] <perigrin> this is with role and has declaration in the exact same order in every case? +[15:25] <kolibrie> yes +[15:25] <perigrin> interesting +[15:25] <kolibrie> that's what I thought +[15:26] <kolibrie> does that sound like something I should write a test for? +[15:27] <perigrin> stevan, ping? +[15:27] <perigrin> I'm not sure what the right answer for composition is. +[15:27] <perigrin> who should win +[15:27] <perigrin> if I were to guess I'd say the class should always win. +[15:27] <kolibrie> that would be my guess, but I thought I would ask to make sure +[15:29] <stevan> kolibrie: please write a test +[15:29] <stevan> I am not exactly sure who should win either,.. but I suspect it is not working correctly right now +[15:29] <stevan> I know exactly why it is doing what it is doing though + +Now I have to decide actually what happens, and how to fix it. +- SL + +{ + package Role::Method; + use Moose::Role; + + sub ghost { 'Role::Method::ghost' } + + package Role::Method2; + use Moose::Role; + + sub ghost { 'Role::Method2::ghost' } + + package Role::Attribute; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Attribute::ghost'); + + package Role::Attribute2; + use Moose::Role; + + has 'ghost' => (is => 'ro', default => 'Role::Attribute2::ghost'); +} + +{ + package My::Test15; + use Moose; + + ::lives_ok { + with 'Role::Method'; + } '... composed the method role into the method class'; + + sub ghost { 'My::Test15::ghost' } + + package My::Test16; + use Moose; + + ::lives_ok { + with 'Role::Method'; + } '... composed the method role into the attribute class'; + + has 'ghost' => (is => 'ro', default => 'My::Test16::ghost'); + + package My::Test17; + use Moose; + + ::lives_ok { + with 'Role::Attribute'; + } '... composed the attribute role into the method class'; + + sub ghost { 'My::Test17::ghost' } + + package My::Test18; + use Moose; + + ::lives_ok { + with 'Role::Attribute'; + } '... composed the attribute role into the attribute class'; + + has 'ghost' => (is => 'ro', default => 'My::Test18::ghost'); + + package My::Test19; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Method2'; + } '... composed method roles into class with method tiebreaker'; + + sub ghost { 'My::Test19::ghost' } + + package My::Test20; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Method2'; + } '... composed method roles into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test20::ghost'); + + package My::Test21; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Attribute2'; + } '... composed attribute roles into class with method tiebreaker'; + + sub ghost { 'My::Test21::ghost' } + + package My::Test22; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Attribute2'; + } '... composed attribute roles into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test22::ghost'); + + package My::Test23; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Attribute'; + } '... composed method and attribute role into class with method tiebreaker'; + + sub ghost { 'My::Test23::ghost' } + + package My::Test24; + use Moose; + + ::lives_ok { + with 'Role::Method', 'Role::Attribute'; + } '... composed method and attribute role into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test24::ghost'); + + package My::Test25; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Method'; + } '... composed attribute and method role into class with method tiebreaker'; + + sub ghost { 'My::Test25::ghost' } + + package My::Test26; + use Moose; + + ::lives_ok { + with 'Role::Attribute', 'Role::Method'; + } '... composed attribute and method role into class with attribute tiebreaker'; + + has 'ghost' => (is => 'ro', default => 'My::Test26::ghost'); +} + +my $test15 = My::Test15->new; +isa_ok($test15, 'My::Test15'); +is($test15->ghost, 'My::Test15::ghost', '... we access the method from the class and ignore the role method'); + +my $test16 = My::Test16->new; +isa_ok($test16, 'My::Test16'); +is($test16->ghost, 'My::Test16::ghost', '... we access the attribute from the class and ignore the role method'); + +my $test17 = My::Test17->new; +isa_ok($test17, 'My::Test17'); +is($test17->ghost, 'My::Test17::ghost', '... we access the method from the class and ignore the role attribute'); + +my $test18 = My::Test18->new; +isa_ok($test18, 'My::Test18'); +is($test18->ghost, 'My::Test18::ghost', '... we access the attribute from the class and ignore the role attribute'); + +my $test19 = My::Test19->new; +isa_ok($test19, 'My::Test19'); +is($test19->ghost, 'My::Test19::ghost', '... we access the method from the class and ignore the role methods'); + +my $test20 = My::Test20->new; +isa_ok($test20, 'My::Test20'); +is($test20->ghost, 'My::Test20::ghost', '... we access the attribute from the class and ignore the role methods'); + +my $test21 = My::Test21->new; +isa_ok($test21, 'My::Test21'); +is($test21->ghost, 'My::Test21::ghost', '... we access the method from the class and ignore the role attributes'); + +my $test22 = My::Test22->new; +isa_ok($test22, 'My::Test22'); +is($test22->ghost, 'My::Test22::ghost', '... we access the attribute from the class and ignore the role attributes'); + +my $test23 = My::Test23->new; +isa_ok($test23, 'My::Test23'); +is($test23->ghost, 'My::Test23::ghost', '... we access the method from the class and ignore the role method and attribute'); + +my $test24 = My::Test24->new; +isa_ok($test24, 'My::Test24'); +is($test24->ghost, 'My::Test24::ghost', '... we access the attribute from the class and ignore the role method and attribute'); + +my $test25 = My::Test25->new; +isa_ok($test25, 'My::Test25'); +is($test25->ghost, 'My::Test25::ghost', '... we access the method from the class and ignore the role attribute and method'); + +my $test26 = My::Test26->new; +isa_ok($test26, 'My::Test26'); +is($test26->ghost, 'My::Test26::ghost', '... we access the attribute from the class and ignore the role attribute and method'); + +=cut + +done_testing; diff --git a/t/roles/role_conflict_edge_cases.t b/t/roles/role_conflict_edge_cases.t new file mode 100644 index 0000000..5fb87e0 --- /dev/null +++ b/t/roles/role_conflict_edge_cases.t @@ -0,0 +1,188 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +Check for repeated inheritance causing +a method conflict (which is not really +a conflict) + +=cut + +{ + package Role::Base; + use Moose::Role; + + sub foo { 'Role::Base::foo' } + + package Role::Derived1; + use Moose::Role; + + with 'Role::Base'; + + package Role::Derived2; + use Moose::Role; + + with 'Role::Base'; + + package My::Test::Class1; + use Moose; + + ::is( ::exception { + with 'Role::Derived1', 'Role::Derived2'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base->meta->has_method('foo'), '... have the method foo as expected'); +ok(Role::Derived1->meta->has_method('foo'), '... have the method foo as expected'); +ok(Role::Derived2->meta->has_method('foo'), '... have the method foo as expected'); +ok(My::Test::Class1->meta->has_method('foo'), '... have the method foo as expected'); + +is(My::Test::Class1->foo, 'Role::Base::foo', '... got the right value from method'); + +=pod + +Check for repeated inheritance 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'; + + ::is( ::exception { + with 'Role::Derived3', 'Role::Derived4'; + }, undef, '... 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::Overridden'); +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 inheritance 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'; + + ::is( ::exception { + with 'Role::Derived5', 'Role::Derived6'; + }, undef, '... 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 inheritance causing +a attr conflict (which is not really +a conflict) + +=cut + +{ + package Role::Base4; + use Moose::Role; + + has 'foo' => (is => 'ro', default => 'Role::Base::foo'); + + package Role::Derived7; + use Moose::Role; + + with 'Role::Base4'; + + package Role::Derived8; + use Moose::Role; + + with 'Role::Base4'; + + package My::Test::Class4; + use Moose; + + ::is( ::exception { + with 'Role::Derived7', 'Role::Derived8'; + }, undef, '... roles composed okay (no conflicts)' ); +} + +ok(Role::Base4->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived7->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived8->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(My::Test::Class4->meta->has_attribute('foo'), '... have the attribute foo as expected'); + +is(My::Test::Class4->new->foo, 'Role::Base::foo', '... got the right value from method'); + +done_testing; diff --git a/t/roles/role_consumers.t b/t/roles/role_consumers.t new file mode 100644 index 0000000..13707f3 --- /dev/null +++ b/t/roles/role_consumers.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Bar::Role; + use Moose::Role; +} + +{ + package Foo; + use Moose; + with 'Foo::Role'; +} + +{ + package Bar; + use Moose; + extends 'Foo'; + with 'Bar::Role'; +} + +{ + package FooBar; + use Moose; + with 'Foo::Role', 'Bar::Role'; +} + +{ + package Foo::Role::User; + use Moose::Role; + with 'Foo::Role'; +} + +{ + package Foo::User; + use Moose; + with 'Foo::Role::User'; +} + +is_deeply([sort Foo::Role->meta->consumers], + ['Bar', 'Foo', 'Foo::Role::User', 'Foo::User', 'FooBar']); +is_deeply([sort Bar::Role->meta->consumers], + ['Bar', 'FooBar']); +is_deeply([sort Foo::Role::User->meta->consumers], + ['Foo::User']); + +done_testing; diff --git a/t/roles/role_exclusion.t b/t/roles/role_exclusion.t new file mode 100644 index 0000000..d6cb80a --- /dev/null +++ b/t/roles/role_exclusion.t @@ -0,0 +1,119 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +The idea and examples for this feature are taken +from the Fortress spec. + +http://research.sun.com/projects/plrg/fortress0903.pdf + +trait OrganicMolecule extends Molecule + excludes { InorganicMolecule } +end +trait InorganicMolecule extends Molecule end + +=cut + +{ + package Molecule; + use Moose::Role; + + package Molecule::Organic; + use Moose::Role; + + with 'Molecule'; + excludes 'Molecule::Inorganic'; + + package Molecule::Inorganic; + use Moose::Role; + + with 'Molecule'; +} + +ok(Molecule::Organic->meta->excludes_role('Molecule::Inorganic'), '... Molecule::Organic exludes Molecule::Inorganic'); +is_deeply( + [ Molecule::Organic->meta->get_excluded_roles_list() ], + [ 'Molecule::Inorganic' ], + '... Molecule::Organic exludes Molecule::Inorganic'); + +=pod + +Check some basic conflicts when combining +the roles into the same class + +=cut + +{ + package My::Test1; + use Moose; + + ::is( ::exception { + with 'Molecule::Organic'; + }, undef, '... adding the role (w/ excluded roles) okay' ); + + package My::Test2; + use Moose; + + ::like( ::exception { + with 'Molecule::Organic', 'Molecule::Inorganic'; + }, qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); + + package My::Test3; + use Moose; + + ::is( ::exception { + with 'Molecule::Organic'; + }, undef, '... adding the role (w/ excluded roles) okay' ); + + ::like( ::exception { + with 'Molecule::Inorganic'; + }, qr/Conflict detected: My::Test3 excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); +} + +ok(My::Test1->does('Molecule::Organic'), '... My::Test1 does Molecule::Organic'); +ok(My::Test1->does('Molecule'), '... My::Test1 does Molecule'); +ok(My::Test1->meta->excludes_role('Molecule::Inorganic'), '... My::Test1 excludes Molecule::Organic'); + +ok(!My::Test2->does('Molecule::Organic'), '... ! My::Test2 does Molecule::Organic'); +ok(!My::Test2->does('Molecule::Inorganic'), '... ! My::Test2 does Molecule::Inorganic'); + +ok(My::Test3->does('Molecule::Organic'), '... My::Test3 does Molecule::Organic'); +ok(My::Test3->does('Molecule'), '... My::Test1 does Molecule'); +ok(My::Test3->meta->excludes_role('Molecule::Inorganic'), '... My::Test3 excludes Molecule::Organic'); +ok(!My::Test3->does('Molecule::Inorganic'), '... ! My::Test3 does Molecule::Inorganic'); + +=pod + +Check some basic conflicts when combining +the roles into the a superclass + +=cut + +{ + package Methane; + use Moose; + + with 'Molecule::Organic'; + + package My::Test4; + use Moose; + + extends 'Methane'; + + ::like( ::exception { + with 'Molecule::Inorganic'; + }, qr/Conflict detected: My::Test4 excludes role \'Molecule::Inorganic\'/, '... cannot add exculded role into class which extends Methane' ); +} + +ok(Methane->does('Molecule::Organic'), '... Methane does Molecule::Organic'); +ok(My::Test4->isa('Methane'), '... My::Test4 isa Methane'); +ok(My::Test4->does('Molecule::Organic'), '... My::Test4 does Molecule::Organic'); +ok(My::Test4->meta->does_role('Molecule::Organic'), '... My::Test4 meat does_role Molecule::Organic'); +ok(My::Test4->meta->excludes_role('Molecule::Inorganic'), '... My::Test4 meta excludes Molecule::Organic'); +ok(!My::Test4->does('Molecule::Inorganic'), '... My::Test4 does Molecule::Inorganic'); + +done_testing; diff --git a/t/roles/role_exclusion_and_alias_bug.t b/t/roles/role_exclusion_and_alias_bug.t new file mode 100644 index 0000000..dc4b0a5 --- /dev/null +++ b/t/roles/role_exclusion_and_alias_bug.t @@ -0,0 +1,67 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package My::Role; + use Moose::Role; + + sub foo { "FOO" } + sub bar { "BAR" } +} + +{ + package My::Class; + use Moose; + + with 'My::Role' => { + -alias => { foo => 'baz', bar => 'gorch' }, + -excludes => ['foo', 'bar'], + }; +} + +{ + my $x = My::Class->new; + isa_ok($x, 'My::Class'); + does_ok($x, 'My::Role'); + + can_ok($x, $_) for qw[baz gorch]; + + ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; + + is($x->baz, 'FOO', '... got the right value'); + is($x->gorch, 'BAR', '... got the right value'); +} + +{ + package My::Role::Again; + use Moose::Role; + + with 'My::Role' => { + -alias => { foo => 'baz', bar => 'gorch' }, + -excludes => ['foo', 'bar'], + }; + + package My::Class::Again; + use Moose; + + with 'My::Role::Again'; +} + +{ + my $x = My::Class::Again->new; + isa_ok($x, 'My::Class::Again'); + does_ok($x, 'My::Role::Again'); + does_ok($x, 'My::Role'); + + can_ok($x, $_) for qw[baz gorch]; + + ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; + + is($x->baz, 'FOO', '... got the right value'); + is($x->gorch, 'BAR', '... got the right value'); +} + +done_testing; diff --git a/t/roles/role_for_combination.t b/t/roles/role_for_combination.t new file mode 100644 index 0000000..d4a1684 --- /dev/null +++ b/t/roles/role_for_combination.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; + +my $OPTS; +do { + package My::Singleton::Role; + use Moose::Role; + + sub foo { 'My::Singleton::Role' } + + package My::Role::Metaclass; + use Moose; + BEGIN { extends 'Moose::Meta::Role' }; + + sub _role_for_combination { + my ($self, $opts) = @_; + $OPTS = $opts; + return My::Singleton::Role->meta; + } + + package My::Special::Role; + use Moose::Role -metaclass => 'My::Role::Metaclass'; + + sub foo { 'My::Special::Role' } + + package My::Usual::Role; + use Moose::Role; + + sub bar { 'My::Usual::Role' } + + package My::Class; + use Moose; + + with ( + 'My::Special::Role' => { number => 1 }, + 'My::Usual::Role' => { number => 2 }, + ); +}; + +is(My::Class->foo, 'My::Singleton::Role', 'role_for_combination applied'); +is(My::Class->bar, 'My::Usual::Role', 'collateral role'); +is_deeply($OPTS, { number => 1 }); + +done_testing; diff --git a/t/roles/roles_and_method_cloning.t b/t/roles/roles_and_method_cloning.t new file mode 100644 index 0000000..1624a98 --- /dev/null +++ b/t/roles/roles_and_method_cloning.t @@ -0,0 +1,77 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Role::Foo; + use Moose::Role; + + sub foo { (caller(0))[3] } +} + +{ + package ClassA; + use Moose; + + with 'Role::Foo'; +} + +{ + my $meth = ClassA->meta->get_method('foo'); + ok( $meth, 'ClassA has a foo method' ); + isa_ok( $meth, 'Moose::Meta::Method' ); + is( $meth->original_method, Role::Foo->meta->get_method('foo'), + 'ClassA->foo was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'ClassA::foo', + 'fq name is ClassA::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +{ + package Role::Bar; + use Moose::Role; + with 'Role::Foo'; + + sub bar { } +} + +{ + my $meth = Role::Bar->meta->get_method('foo'); + ok( $meth, 'Role::Bar has a foo method' ); + is( $meth->original_method, Role::Foo->meta->get_method('foo'), + 'Role::Bar->foo was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'Role::Bar::foo', + 'fq name is Role::Bar::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +{ + package ClassB; + use Moose; + + with 'Role::Bar'; +} + +{ + my $meth = ClassB->meta->get_method('foo'); + ok( $meth, 'ClassB has a foo method' ); + is( $meth->original_method, Role::Bar->meta->get_method('foo'), + 'ClassA->foo was cloned from Role::Bar->foo' ); + is( $meth->original_method->original_method, Role::Foo->meta->get_method('foo'), + '... which in turn was cloned from Role::Foo->foo' ); + is( $meth->fully_qualified_name, 'ClassB::foo', + 'fq name is ClassA::foo' ); + is( $meth->original_fully_qualified_name, 'Role::Foo::foo', + 'original fq name is Role::Foo::foo' ); +} + +isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo"); + +is( ClassB->foo, 'Role::Foo::foo', 'ClassB::foo knows its name' ); +is( ClassA->foo, 'Role::Foo::foo', 'ClassA::foo knows its name' ); + +done_testing; diff --git a/t/roles/roles_and_req_method_edge_cases.t b/t/roles/roles_and_req_method_edge_cases.t new file mode 100644 index 0000000..601dbf1 --- /dev/null +++ b/t/roles/roles_and_req_method_edge_cases.t @@ -0,0 +1,277 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +NOTE: +A fair amount of these tests will likely be irrelevant +once we have more fine grained control over the class +building process. A lot of the edge cases tested here +are actually related to class construction order and +not any real functionality. +- SL + +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; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... 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'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass' ); + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + package Class::ProvideFoo::Override2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, although it is overriden locally' ); + +} + +=pod + +Now same thing, but with a before +method modifier. + +=cut + +{ + package Class::ProvideFoo::Before1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass' ); + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + package Class::ProvideFoo::Before2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, although it is a before modifier locally' ); + + package Class::ProvideFoo::Before3; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + sub foo { 'Class::ProvideFoo::foo' } + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists locally, and it is modified locally' ); + + 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'); + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists in the symbol table (and we will live)' ); + +} + +=pod + +Now same thing, but with a method from an attribute +method modifier. + +=cut + +{ + + package Class::ProvideFoo::Attr1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method will be found in the superclass (but then overriden)' ); + + has 'foo' => (is => 'ro'); + + package Class::ProvideFoo::Attr2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + has 'foo' => (is => 'ro'); + + ::is( ::exception { + with 'Role::RequireFoo'; + }, undef, '... the required "foo" method exists, and is an accessor' ); +} + +# ... +# a method required in a role, but then +# implemented in the superclass (as an +# attribute accessor too) + +{ + package Foo::Class::Base; + use Moose; + + has 'bar' => ( + isa => 'Int', + is => 'rw', + default => sub { 1 } + ); +} +{ + package Foo::Role; + use Moose::Role; + + requires 'bar'; + + has 'foo' => ( + isa => 'Int', + is => 'rw', + lazy => 1, + default => sub { (shift)->bar + 1 } + ); +} +{ + package Foo::Class::Child; + use Moose; + extends 'Foo::Class::Base'; + + ::is( ::exception { + with 'Foo::Role'; + }, undef, '... our role combined successfully' ); +} + +# a method required in a role and implemented in a superclass, with a method +# modifier in the subclass. this should live, but dies in 0.26 -- hdp, +# 2007-10-11 + +{ + package Bar::Class::Base; + use Moose; + + sub bar { "hello!" } +} +{ + package Bar::Role; + use Moose::Role; + requires 'bar'; +} +{ + package Bar::Class::Child; + use Moose; + extends 'Bar::Class::Base'; + after bar => sub { "o noes" }; + # technically we could run lives_ok here, too, but putting it into a + # grandchild class makes it more obvious why this matters. +} +{ + package Bar::Class::Grandchild; + use Moose; + extends 'Bar::Class::Child'; + ::is( ::exception { + with 'Bar::Role'; + }, undef, 'required method exists in superclass as non-modifier, so we live' ); +} + +{ + package Bar2::Class::Base; + use Moose; + + sub bar { "hello!" } +} +{ + package Bar2::Role; + use Moose::Role; + requires 'bar'; +} +{ + package Bar2::Class::Child; + use Moose; + extends 'Bar2::Class::Base'; + override bar => sub { "o noes" }; + # technically we could run lives_ok here, too, but putting it into a + # grandchild class makes it more obvious why this matters. +} +{ + package Bar2::Class::Grandchild; + use Moose; + extends 'Bar2::Class::Child'; + ::is( ::exception { + with 'Bar2::Role'; + }, undef, 'required method exists in superclass as non-modifier, so we live' ); +} + +done_testing; diff --git a/t/roles/roles_applied_in_create.t b/t/roles/roles_applied_in_create.t new file mode 100644 index 0000000..9f617ad --- /dev/null +++ b/t/roles/roles_applied_in_create.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Moose::Meta::Class; +use Moose::Util; + +use lib 't/lib'; + + +# Note that this test passed (pre svn #5543) if we inlined the role +# definitions in this file, as it was very timing sensitive. +is( exception { + my $builder_meta = Moose::Meta::Class->create( + 'YATTA' => ( + superclass => 'Moose::Meta::Class', + roles => [qw( Role::Interface Role::Child )], + ) + ); +}, undef, 'Create a new class with several roles' ); + +done_testing; diff --git a/t/roles/run_time_role_composition.t b/t/roles/run_time_role_composition.t new file mode 100644 index 0000000..c847df3 --- /dev/null +++ b/t/roles/run_time_role_composition.t @@ -0,0 +1,111 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util qw(blessed); + + +=pod + +This test can be used as a basis for the runtime role composition. +Apparently it is not as simple as just making an anon class. One of +the problems is the way that anon classes are DESTROY-ed, which is +not very compatible with how instances are dealt with. + +=cut + +{ + package Bark; + use Moose::Role; + + sub talk { 'woof' } + + package Sleeper; + use Moose::Role; + + sub sleep { 'snore' } + sub talk { 'zzz' } + + package My::Class; + use Moose; + + sub sleep { 'nite-nite' } +} + +my $obj = My::Class->new; +isa_ok($obj, 'My::Class'); + +my $obj2 = My::Class->new; +isa_ok($obj2, 'My::Class'); + +{ + ok(!$obj->can( 'talk' ), "... the role is not composed yet"); + + ok(!$obj->does('Bark'), '... we do not do any roles yet'); + + Bark->meta->apply($obj); + + ok($obj->does('Bark'), '... we now do the Bark role'); + ok(!My::Class->does('Bark'), '... the class does not do the Bark role'); + + isa_ok($obj, 'My::Class'); + isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class'); + + ok(!My::Class->can('talk'), "... the role is not composed at the class level"); + ok($obj->can('talk'), "... the role is now composed at the object level"); + + is($obj->talk, 'woof', '... got the right return value for the newly composed method'); +} + +{ + ok(!$obj2->does('Sleeper'), '... we do not do any roles yet'); + + Sleeper->meta->apply($obj2); + + ok($obj2->does('Sleeper'), '... we now do the Sleeper role'); + isnt(blessed($obj), blessed($obj2), '... they DO NOT share the same anon-class/role thing'); +} + +{ + is($obj->sleep, 'nite-nite', '... the original method responds as expected'); + + ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role'); + + Sleeper->meta->apply($obj); + + ok($obj->does('Bark'), '... we still do the Bark role'); + ok($obj->does('Sleeper'), '... we now do the Sleeper role too'); + + ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role'); + + isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); + + isa_ok($obj, 'My::Class'); + + is(My::Class->sleep, 'nite-nite', '... the original method still responds as expected'); + + is($obj->sleep, 'snore', '... got the right return value for the newly composed method'); + is($obj->talk, 'zzz', '... got the right return value for the newly composed method'); +} + +{ + ok(!$obj2->does('Bark'), '... we do not do Bark yet'); + + Bark->meta->apply($obj2); + + ok($obj2->does('Bark'), '... we now do the Bark role'); + isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); +} + +# test that anon classes are equivalent after role composition in the same order +{ + foreach ($obj, $obj2) { + $_ = My::Class->new; + Bark->meta->apply($_); + Sleeper->meta->apply($_); + } + is(blessed($obj), blessed($obj2), '... they now share the same anon-class/role thing'); +} + +done_testing; diff --git a/t/roles/runtime_roles_and_attrs.t b/t/roles/runtime_roles_and_attrs.t new file mode 100644 index 0000000..ef5c06c --- /dev/null +++ b/t/roles/runtime_roles_and_attrs.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Dog; + use Moose::Role; + + sub talk { 'woof' } + + has fur => ( + isa => "Str", + is => "rw", + default => "dirty", + ); + + package Foo; + use Moose; + + has 'dog' => ( + is => 'rw', + does => 'Dog', + ); +} + +my $obj = Foo->new; +isa_ok($obj, 'Foo'); + +ok(!$obj->can( 'talk' ), "... the role is not composed yet"); +ok(!$obj->can( 'fur' ), 'ditto'); +ok(!$obj->does('Dog'), '... we do not do any roles yet'); + +isnt( exception { + $obj->dog($obj) +}, undef, '... and setting the accessor fails (not a Dog yet)' ); + +Dog->meta->apply($obj); + +ok($obj->does('Dog'), '... we now do the Bark role'); +ok($obj->can('talk'), "... the role is now composed at the object level"); +ok($obj->can('fur'), "it has fur"); + +is($obj->talk, 'woof', '... got the right return value for the newly composed method'); + +is( exception { + $obj->dog($obj) +}, undef, '... and setting the accessor is okay' ); + +is($obj->fur, "dirty", "role attr initialized"); + +done_testing; diff --git a/t/roles/runtime_roles_and_nonmoose.t b/t/roles/runtime_roles_and_nonmoose.t new file mode 100644 index 0000000..4365eb6 --- /dev/null +++ b/t/roles/runtime_roles_and_nonmoose.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Dog; + use Moose::Role; + + sub talk { 'woof' } + + package Foo; + use Moose; + + has 'dog' => ( + is => 'rw', + does => 'Dog', + ); + + no Moose; + + package Bar; + + sub new { + return bless {}, shift; + } +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +ok(!$bar->can( 'talk' ), "... the role is not composed yet"); + +isnt( exception { + $foo->dog($bar) +}, undef, '... and setting the accessor fails (not a Dog yet)' ); + +Dog->meta->apply($bar); + +ok($bar->can('talk'), "... the role is now composed at the object level"); + +is($bar->talk, 'woof', '... got the right return value for the newly composed method'); + +is( exception { + $foo->dog($bar) +}, undef, '... and setting the accessor is okay' ); + +done_testing; diff --git a/t/roles/runtime_roles_w_params.t b/t/roles/runtime_roles_w_params.t new file mode 100644 index 0000000..6d5353f --- /dev/null +++ b/t/roles/runtime_roles_w_params.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + has 'bar' => (is => 'ro'); + + package Bar; + use Moose::Role; + + has 'baz' => (is => 'ro', default => 'BAZ'); +} + +# normal ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'BAZ', '... got the expect value'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo, (rebless_params => { baz => 'FOO-BAZ' })) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->apply($foo, (rebless_params => { bar => 'FOO-BAR', baz => 'FOO-BAZ' })) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); +} + +done_testing; diff --git a/t/roles/use_base_does.t b/t/roles/use_base_does.t new file mode 100644 index 0000000..a3d5b41 --- /dev/null +++ b/t/roles/use_base_does.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo::Role; + use Moose::Role; +} + +{ + package Foo; + use Moose; + + with 'Foo::Role'; +} + +{ + package Foo::Sub; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub2; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub3; + use parent -norequire => 'Foo'; +} + +{ + package Foo::Sub4; + use parent -norequire => 'Foo'; +} + +ok(Foo::Sub->does('Foo::Role'), "class does Foo::Role"); +ok(Foo::Sub2->new->does('Foo::Role'), "object does Foo::Role"); +ok(!Foo::Sub3->does('Bar::Role'), "class doesn't do Bar::Role"); +ok(!Foo::Sub4->new->does('Bar::Role'), "object doesn't do Bar::Role"); + +done_testing; |