X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=t%2F030_roles%2F009_more_role_edge_cases.t;fp=t%2F030_roles%2F009_more_role_edge_cases.t;h=d7c95a411ee43fdeb57c00c281687df9810dfccd;hp=0000000000000000000000000000000000000000;hb=6cfa1e5e70616fb102915489c02d8347ffa912fb;hpb=4f9945f5a128e120049ce8a7a30cf469d1568b9b

diff --git a/t/030_roles/009_more_role_edge_cases.t b/t/030_roles/009_more_role_edge_cases.t
new file mode 100644
index 0000000..d7c95a4
--- /dev/null
+++ b/t/030_roles/009_more_role_edge_cases.t
@@ -0,0 +1,256 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 74;
+use Test::Exception;
+
+
+
+{
+    # NOTE:
+    # this tests that repeated role
+    # composition will not cause
+    # a conflict between two methods
+    # which are actually the same anyway
+
+    {
+        package RootA;
+        use Mouse::Role;
+
+        sub foo { "RootA::foo" }
+
+        package SubAA;
+        use Mouse::Role;
+
+        with "RootA";
+
+        sub bar { "SubAA::bar" }
+
+        package SubAB;
+        use Mouse;
+
+        ::lives_ok {
+            with "SubAA", "RootA";
+        } '... 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;
+    lives_ok {
+        $foo_rv = $i->foo;
+    } '... 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 Mouse::Role;
+
+        sub foo { "RootB::foo" }
+
+        package SubBA;
+        use Mouse::Role;
+
+        with "RootB";
+
+        has counter => (
+            isa => "Num",
+            is  => "rw",
+            default => 0,
+        );
+
+        after foo => sub {
+            $_[0]->counter( $_[0]->counter + 1 );
+        };
+
+        package SubBB;
+        use Mouse;
+
+        ::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)" );
+
+    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 Mouse::Role;
+
+        sub foo { "RootC::foo" }
+
+        package SubCA;
+        use Mouse::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 Mouse::Role;
+
+        requires "method";
+        requires "other";
+
+        sub another { "abstract" }
+
+        package ConcreteA;
+        use Mouse::Role;
+        with "Abstract";
+
+        sub other { "concrete a" }
+
+        package ConcreteB;
+        use Mouse::Role;
+        with "Abstract";
+
+        sub method { "concrete b" }
+
+        package ConcreteC;
+        use Mouse::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 Mouse;
+
+        eval { with ::shuffle qw/ConcreteA ConcreteB/ };
+        ::ok( !$@, "simple composition without abstract" ) || ::diag $@;
+
+        package SimpleClassWithAll;
+        use Mouse;
+
+        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 Mouse;
+
+        eval { with ::shuffle qw/ConcreteC ConcreteB/ };
+        ::ok( !$@, "composition without abstract" ) || ::diag $@;
+
+        package ClassWithAll;
+        use Mouse;
+
+        eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ };
+        ::ok( !$@, "composition with abstract" ) || ::diag $@;
+
+        package ClassWithEverything;
+        use Mouse;
+
+        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" );
+    }
+}