6 use Test::More tests => 74;
13 # this tests that repeated role
14 # composition will not cause
15 # a conflict between two methods
16 # which are actually the same anyway
22 sub foo { "RootA::foo" }
29 sub bar { "SubAA::bar" }
35 with "SubAA", "RootA";
36 } '... role was composed as expected';
39 ok( SubAB->does("SubAA"), "does SubAA");
40 ok( SubAB->does("RootA"), "does RootA");
42 isa_ok( my $i = SubAB->new, "SubAB" );
45 is( $i->bar, "SubAA::bar", "... got thr right bar rv" );
51 } '... called foo successfully';
52 is($foo_rv, "RootA::foo", "... got the right foo rv");
57 # this edge cases shows the application of
58 # an after modifier over a method which
59 # was added during role composotion.
60 # The way this will work is as follows:
61 # role SubBA will consume RootB and
62 # get a local copy of RootB::foo, it
63 # will also store a deferred after modifier
64 # to be applied to whatever class SubBA is
66 # When class SubBB comsumed role SubBA, the
67 # RootB::foo method is added to SubBB, then
68 # the deferred after modifier from SubBA is
70 # It is important to note that the application
71 # of the after modifier does not happen until
72 # role SubBA is composed into SubAA.
78 sub foo { "RootB::foo" }
92 $_[0]->counter( $_[0]->counter + 1 );
100 } '... composed the role successfully';
103 ok( SubBB->does("SubBA"), "BB does SubBA" );
104 ok( SubBB->does("RootB"), "BB does RootB" );
106 isa_ok( my $i = SubBB->new, "SubBB" );
113 } '... called foo successfully';
114 is( $foo_rv, "RootB::foo", "foo rv" );
115 is( $i->counter, 1, "after hook called" );
117 lives_ok { $i->foo } '... called foo successfully (again)';
118 is( $i->counter, 2, "after hook called (again)" );
120 ok(SubBA->meta->has_method('foo'), '... this has the foo method');
123 # $subba_foo_rv = SubBA::foo();
124 #} '... called the sub as a function correctly';
125 #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version');
130 # this checks that an override method
131 # does not try to trample over a locally
132 # composed in method. In this case the
133 # RootC::foo, which is composed into
134 # SubCA cannot be trampled with an
140 sub foo { "RootC::foo" }
148 override foo => sub { "overridden" };
149 } '... cannot compose an override over a local method';
154 # need to talk to Yuval about the motivation behind
155 # this test, I am not sure we are testing anything
156 # useful here (although more tests cant hurt)
159 use List::Util qw/shuffle/;
168 sub another { "abstract" }
174 sub other { "concrete a" }
180 sub method { "concrete b" }
187 # this was originally override, but
188 # that wont work (see above set of tests)
189 # so I switched it to around.
190 # However, this may not be testing the
191 # same thing that was originally intended
192 around other => sub {
193 return ( (shift)->() . " + c" );
196 package SimpleClassWithSome;
199 eval { with ::shuffle qw/ConcreteA ConcreteB/ };
200 ::ok( !$@, "simple composition without abstract" ) || ::diag $@;
202 package SimpleClassWithAll;
205 eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ };
206 ::ok( !$@, "simple composition with abstract" ) || ::diag $@;
209 foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) {
210 foreach my $role (qw/Abstract ConcreteA ConcreteB/) {
211 ok( $class->does($role), "$class does $role");
214 foreach my $method (qw/method other another/) {
215 can_ok( $class, $method );
218 is( eval { $class->another }, "abstract", "provided by abstract" );
219 is( eval { $class->other }, "concrete a", "provided by concrete a" );
220 is( eval { $class->method }, "concrete b", "provided by concrete b" );
224 package ClassWithSome;
227 eval { with ::shuffle qw/ConcreteC ConcreteB/ };
228 ::ok( !$@, "composition without abstract" ) || ::diag $@;
230 package ClassWithAll;
233 eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ };
234 ::ok( !$@, "composition with abstract" ) || ::diag $@;
236 package ClassWithEverything;
239 eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash
240 ::ok( !$@, "can compose ConcreteA and ConcreteC together" );
243 foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) {
244 foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) {
245 ok( $class->does($role), "$class does $role");
248 foreach my $method (qw/method other another/) {
249 can_ok( $class, $method );
252 is( eval { $class->another }, "abstract", "provided by abstract" );
253 is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" );
254 is( eval { $class->method }, "concrete b", "provided by concrete b" );