| 1 | #!./perl |
| 2 | |
| 3 | use strict; |
| 4 | use warnings; |
| 5 | |
| 6 | require q(./test.pl); plan(tests => 2); |
| 7 | |
| 8 | =pod |
| 9 | |
| 10 | This tests a strange bug found by Matt S. Trout |
| 11 | while building DBIx::Class. Thanks Matt!!!! |
| 12 | |
| 13 | <A> |
| 14 | / \ |
| 15 | <C> <B> |
| 16 | \ / |
| 17 | <D> |
| 18 | |
| 19 | =cut |
| 20 | |
| 21 | { |
| 22 | package Diamond_A; |
| 23 | use mro 'c3'; |
| 24 | |
| 25 | sub foo { 'Diamond_A::foo' } |
| 26 | } |
| 27 | { |
| 28 | package Diamond_B; |
| 29 | use base 'Diamond_A'; |
| 30 | use mro 'c3'; |
| 31 | |
| 32 | sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo } |
| 33 | } |
| 34 | { |
| 35 | package Diamond_C; |
| 36 | use mro 'c3'; |
| 37 | use base 'Diamond_A'; |
| 38 | |
| 39 | } |
| 40 | { |
| 41 | package Diamond_D; |
| 42 | use base ('Diamond_C', 'Diamond_B'); |
| 43 | use mro 'c3'; |
| 44 | |
| 45 | sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo } |
| 46 | } |
| 47 | |
| 48 | ok(eq_array( |
| 49 | mro::get_linear_isa('Diamond_D'), |
| 50 | [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ] |
| 51 | ), '... got the right MRO for Diamond_D'); |
| 52 | |
| 53 | is(Diamond_D->foo, |
| 54 | 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo', |
| 55 | '... got the right next::method dispatch path'); |