},
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();
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More tests => 25;
use Test::Exception;
BEGIN {
=cut
-=begin nonsense
-
{
package FooRole;
use Moose::Role;
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;
{ 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
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;
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;
extends 'BarClass';
with 'FooRole';
-
- sub blau { 'FooClass::blau' }
sub goo { 'FooClass::goo' } # << overrides the one from the 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');
-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);
}
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');
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
use strict;
use warnings;
-use Test::More tests => 44;
+use Test::More tests => 67;
use Test::Exception;
BEGIN {
=cut
-=begin nonsense
-
{
package Role::Bling;
use Moose::Role;
=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
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
projects / gitmo/Moose.git / commitdiff