| 1 | #!./perl |
| 2 | |
| 3 | use strict; |
| 4 | use warnings; |
| 5 | |
| 6 | require q(./test.pl); plan(tests => 4); |
| 7 | |
| 8 | =pod |
| 9 | |
| 10 | This tests the classic diamond inheritence pattern. |
| 11 | |
| 12 | <A> |
| 13 | / \ |
| 14 | <B> <C> |
| 15 | \ / |
| 16 | <D> |
| 17 | |
| 18 | =cut |
| 19 | |
| 20 | { |
| 21 | package Diamond_A; |
| 22 | sub hello { 'Diamond_A::hello' } |
| 23 | } |
| 24 | { |
| 25 | package Diamond_B; |
| 26 | use base 'Diamond_A'; |
| 27 | } |
| 28 | { |
| 29 | package Diamond_C; |
| 30 | use base 'Diamond_A'; |
| 31 | |
| 32 | sub hello { 'Diamond_C::hello' } |
| 33 | } |
| 34 | { |
| 35 | package Diamond_D; |
| 36 | use base ('Diamond_B', 'Diamond_C'); |
| 37 | use mro 'dfs'; |
| 38 | } |
| 39 | |
| 40 | ok(eq_array( |
| 41 | mro::get_linear_isa('Diamond_D'), |
| 42 | [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ] |
| 43 | ), '... got the right MRO for Diamond_D'); |
| 44 | |
| 45 | is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected'); |
| 46 | is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); |
| 47 | is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); |