From: Yuval Kogman Date: Fri, 14 Jul 2006 01:39:41 +0000 (+0000) Subject: clean up the tests a bit X-Git-Tag: 0_12~24^2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8256469a287c0cde098e033f249a3d5442f65ea9;p=gitmo%2FMoose.git clean up the tests a bit --- diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 24cc791..c4b90c0 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -119,7 +119,9 @@ use Moose::Util::TypeConstraints; }, super => sub { my $meta = _find_meta(); - return subname 'Moose::Role::super' => sub {}; + return subname 'Moose::Role::super' => sub { + confess "Moose::Role cannot support 'super'"; + }; }, override => sub { my $meta = _find_meta(); diff --git a/t/041_role.t b/t/041_role.t index 2c312eb..5d1195e 100644 --- a/t/041_role.t +++ b/t/041_role.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 1; +use Test::More tests => 25; use Test::Exception; BEGIN { @@ -20,8 +20,6 @@ words, should 'has_method' return true for them? =cut -=begin nonsense - { package FooRole; use Moose::Role; @@ -33,20 +31,15 @@ words, should 'has_method' return true for them? sub foo { 'FooRole::foo' } sub boo { 'FooRole::boo' } - - before 'boo' => sub { "FooRole::boo:before" }; - - after 'boo' => sub { "FooRole::boo:after1" }; - after 'boo' => sub { "FooRole::boo:after2" }; - - around 'boo' => sub { "FooRole::boo:around" }; - - override 'bling' => sub { "FooRole::bling:override" }; - override 'fling' => sub { "FooRole::fling:override" }; - + ::dies_ok { extends() } '... extends() is not supported'; - ::dies_ok { augment() } '... augment() is not supported'; - ::dies_ok { inner() } '... inner() is not supported'; + ::dies_ok { augment() } '... augment() is not supported'; + ::dies_ok { inner() } '... inner() is not supported'; + ::dies_ok { overrides() } '... overrides() is not supported'; + ::dies_ok { super() } '... super() is not supported'; + ::dies_ok { after() } '... after() is not supported'; + ::dies_ok { before() } '... before() is not supported'; + ::dies_ok { around() } '... around() is not supported'; } my $foo_role = FooRole->meta; @@ -95,56 +88,3 @@ is_deeply( { is => 'ro' }, '... got the correct description of the baz attribute'); -# method modifiers - -ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); -is(($foo_role->get_before_method_modifiers('boo'))[0]->(), - "FooRole::boo:before", - '... got the right method back'); - -is_deeply( - [ $foo_role->get_method_modifier_list('before') ], - [ 'boo' ], - '... got the right list of before method modifiers'); - -ok($foo_role->has_after_method_modifiers('boo'), '... now we have a boo:after modifier'); -is(($foo_role->get_after_method_modifiers('boo'))[0]->(), - "FooRole::boo:after1", - '... got the right method back'); -is(($foo_role->get_after_method_modifiers('boo'))[1]->(), - "FooRole::boo:after2", - '... got the right method back'); - -is_deeply( - [ $foo_role->get_method_modifier_list('after') ], - [ 'boo' ], - '... got the right list of after method modifiers'); - -ok($foo_role->has_around_method_modifiers('boo'), '... now we have a boo:around modifier'); -is(($foo_role->get_around_method_modifiers('boo'))[0]->(), - "FooRole::boo:around", - '... got the right method back'); - -is_deeply( - [ $foo_role->get_method_modifier_list('around') ], - [ 'boo' ], - '... got the right list of around method modifiers'); - -## overrides - -ok($foo_role->has_override_method_modifier('bling'), '... now we have a bling:override modifier'); -is($foo_role->get_override_method_modifier('bling')->(), - "FooRole::bling:override", - '... got the right method back'); - -ok($foo_role->has_override_method_modifier('fling'), '... now we have a fling:override modifier'); -is($foo_role->get_override_method_modifier('fling')->(), - "FooRole::fling:override", - '... got the right method back'); - -is_deeply( - [ sort $foo_role->get_method_modifier_list('override') ], - [ 'bling', 'fling' ], - '... got the right list of override method modifiers'); - -=cut diff --git a/t/042_apply_role.t b/t/042_apply_role.t index 5a3b150..d41ba60 100644 --- a/t/042_apply_role.t +++ b/t/042_apply_role.t @@ -3,14 +3,14 @@ use strict; use warnings; -use Test::More tests => 1; +use Test::More tests => 33; use Test::Exception; BEGIN { use_ok('Moose::Role'); } -=begin nonsense + { package FooRole; @@ -21,13 +21,6 @@ BEGIN { sub goo { 'FooRole::goo' } sub foo { 'FooRole::foo' } - - override 'boo' => sub { 'FooRole::boo -> ' . super() }; - - around 'blau' => sub { - my $c = shift; - 'FooRole::blau -> ' . $c->(); - }; package BarClass; use Moose; @@ -40,8 +33,6 @@ BEGIN { extends 'BarClass'; with 'FooRole'; - - sub blau { 'FooClass::blau' } sub goo { 'FooClass::goo' } # << overrides the one from the role ... } @@ -64,7 +55,7 @@ dies_ok { ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole'); ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole'); -foreach my $method_name (qw(bar baz foo boo blau goo)) { +foreach my $method_name (qw(bar baz foo goo)) { ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name); } @@ -86,9 +77,7 @@ ok(!$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole can_ok($foo, 'bar'); can_ok($foo, 'baz'); can_ok($foo, 'foo'); -can_ok($foo, 'boo'); can_ok($foo, 'goo'); -can_ok($foo, 'blau'); is($foo->foo, 'FooRole::foo', '... got the right value of foo'); is($foo->goo, 'FooClass::goo', '... got the right value of goo'); @@ -113,8 +102,4 @@ lives_ok { is($foo->bar, $foo2, '... got the right value for bar now'); -is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo'); -is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau'); - -=cut diff --git a/t/044_role_conflict_detection.t b/t/044_role_conflict_detection.t index bb33520..712c491 100644 --- a/t/044_role_conflict_detection.t +++ b/t/044_role_conflict_detection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 44; +use Test::More tests => 67; use Test::Exception; BEGIN { @@ -87,8 +87,6 @@ Role method conflicts =cut -=begin nonsense - { package Role::Bling; use Moose::Role; @@ -254,102 +252,3 @@ Role override method conflicts =cut -=begin nonsense - -{ - package Role::Plot; - use Moose::Role; - - override 'twist' => sub { - super() . ' -> Role::Plot::twist'; - }; - - package Role::Truth; - use Moose::Role; - - override 'twist' => sub { - super() . ' -> Role::Truth::twist'; - }; -} - -{ - package My::Test::Base; - use Moose; - - sub twist { 'My::Test::Base::twist' } - - package My::Test11; - use Moose; - - extends 'My::Test::Base'; - - ::lives_ok { - with 'Role::Truth'; - } '... composed the role with override okay'; - - package My::Test12; - use Moose; - - extends 'My::Test::Base'; - - ::lives_ok { - with 'Role::Plot'; - } '... composed the role with override okay'; - - package My::Test13; - use Moose; - - ::dies_ok { - with 'Role::Plot'; - } '... cannot compose it because we have no superclass'; - - package My::Test14; - use Moose; - - extends 'My::Test::Base'; - - ::throws_ok { - with 'Role::Plot', 'Role::Truth'; - } qr/Two \'override\' methods of the same name encountered/, - '... cannot compose it because we have no superclass'; -} - -ok(My::Test11->meta->has_method('twist'), '... the twist method has been added'); -ok(My::Test12->meta->has_method('twist'), '... the twist method has been added'); -ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added'); -ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added'); - -ok(!My::Test11->does('Role::Plot'), '... our class does() the correct roles'); -ok(My::Test11->does('Role::Truth'), '... our class does() the correct roles'); -ok(!My::Test12->does('Role::Truth'), '... our class does() the correct roles'); -ok(My::Test12->does('Role::Plot'), '... our class does() the correct roles'); -ok(!My::Test13->does('Role::Plot'), '... our class does() the correct roles'); -ok(!My::Test14->does('Role::Truth'), '... our class does() the correct roles'); -ok(!My::Test14->does('Role::Plot'), '... our class does() the correct roles'); - -is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Truth::twist', '... got the right method return'); -is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Plot::twist', '... got the right method return'); -ok(!My::Test13->can('twist'), '... no twist method here at all'); -is(My::Test14->twist(), 'My::Test::Base::twist', '... got the right method return (from superclass)'); - -{ - package Role::Reality; - use Moose::Role; - - ::throws_ok { - with 'Role::Plot'; - } qr/A local method of the same name as been found/, - '... could not compose roles here, it dies'; - - sub twist { - 'Role::Reality::twist'; - } -} - -ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added'); -ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles'); -is(Role::Reality->meta->get_method('twist')->(), - 'Role::Reality::twist', - '... the twist method returns the right value'); - -=cut diff --git a/t/048_more_role_edge_cases.t b/t/048_more_role_edge_cases.t index 2c9c957..d7a1166 100644 --- a/t/048_more_role_edge_cases.t +++ b/t/048_more_role_edge_cases.t @@ -54,210 +54,3 @@ BEGIN { is($foo_rv, "RootA::foo", "... got the right foo rv"); } -=begin nonsense - -{ - # NOTE: - # this edge cases shows the application of - # an after modifier over a method which - # was added during role composotion. - # The way this will work is as follows: - # role SubBA will consume RootB and - # get a local copy of RootB::foo, it - # will also store a deferred after modifier - # to be applied to whatever class SubBA is - # composed into. - # When class SubBB comsumed role SubBA, the - # RootB::foo method is added to SubBB, then - # the deferred after modifier from SubBA is - # applied to it. - # It is important to note that the application - # of the after modifier does not happen until - # role SubBA is composed into SubAA. - - { - package RootB; - use Moose::Role; - - sub foo { "RootB::foo" } - - package SubBA; - use Moose::Role; - - with "RootB"; - - has counter => ( - isa => "Num", - is => "rw", - default => 0, - ); - - after foo => sub { - $_[0]->counter( $_[0]->counter + 1 ); - }; - - package SubBB; - use Moose; - - ::lives_ok { - with "SubBA"; - } '... composed the role successfully'; - } - - ok( SubBB->does("SubBA"), "BB does SubBA" ); - ok( SubBB->does("RootB"), "BB does RootB" ); - - isa_ok( my $i = SubBB->new, "SubBB" ); - - can_ok( $i, "foo" ); - - my $foo_rv; - lives_ok { - $foo_rv = $i->foo - } '... called foo successfully'; - is( $foo_rv, "RootB::foo", "foo rv" ); - is( $i->counter, 1, "after hook called" ); - - lives_ok { $i->foo } '... called foo successfully (again)'; - is( $i->counter, 2, "after hook called (again)" ); - - can_ok('SubBA', 'foo'); - my $subba_foo_rv; - lives_ok { - $subba_foo_rv = SubBA::foo(); - } '... called the sub as a function correctly'; - is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); -} - -{ - # NOTE: - # this checks that an override method - # does not try to trample over a locally - # composed in method. In this case the - # RootC::foo, which is composed into - # SubCA cannot be trampled with an - # override of 'foo' - { - package RootC; - use Moose::Role; - - sub foo { "RootC::foo" } - - package SubCA; - use Moose::Role; - - with "RootC"; - - ::dies_ok { - override foo => sub { "overridden" }; - } '... cannot compose an override over a local method'; - } -} - -# NOTE: -# need to talk to Yuval about the motivation behind -# this test, I am not sure we are testing anything -# useful here (although more tests cant hurt) - - -{ - use List::Util qw/shuffle/; - - { - package Abstract; - use Moose::Role; - - requires "method"; - requires "other"; - - sub another { "abstract" } - - package ConcreteA; - use Moose::Role; - with "Abstract"; - - sub other { "concrete a" } - - package ConcreteB; - use Moose::Role; - with "Abstract"; - - sub method { "concrete b" } - - package ConcreteC; - use Moose::Role; - with "ConcreteA"; - - # NOTE: - # this was originally override, but - # that wont work (see above set of tests) - # so I switched it to around. - # However, this may not be testing the - # same thing that was originally intended - around other => sub { - return ( (shift)->() . " + c" ); - }; - - package SimpleClassWithSome; - use Moose; - - eval { with ::shuffle qw/ConcreteA ConcreteB/ }; - ::ok( !$@, "simple composition without abstract" ) || ::diag $@; - - package SimpleClassWithAll; - use Moose; - - eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ }; - ::ok( !$@, "simple composition with abstract" ) || ::diag $@; - } - - foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) { - foreach my $role (qw/Abstract ConcreteA ConcreteB/) { - ok( $class->does($role), "$class does $role"); - } - - foreach my $method (qw/method other another/) { - can_ok( $class, $method ); - } - - is( eval { $class->another }, "abstract", "provided by abstract" ); - is( eval { $class->other }, "concrete a", "provided by concrete a" ); - is( eval { $class->method }, "concrete b", "provided by concrete b" ); - } - - { - package ClassWithSome; - use Moose; - - eval { with ::shuffle qw/ConcreteC ConcreteB/ }; - ::ok( !$@, "composition without abstract" ) || ::diag $@; - - package ClassWithAll; - use Moose; - - eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; - ::ok( !$@, "composition with abstract" ) || ::diag $@; - - package ClassWithEverything; - use Moose; - - eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash - ::ok( !$@, "can compose ConcreteA and ConcreteC together" ); - } - - foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) { - foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) { - ok( $class->does($role), "$class does $role"); - } - - foreach my $method (qw/method other another/) { - can_ok( $class, $method ); - } - - is( eval { $class->another }, "abstract", "provided by abstract" ); - is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" ); - is( eval { $class->method }, "concrete b", "provided by concrete b" ); - } -} - -=cut