xref: /openbsd/gnu/usr.bin/perl/t/mro/basic_01_dfs.t (revision 4cfece93) 
1#!./perl
2
3use strict;
4use warnings;
5
6require q(./test.pl); plan(tests => 4);
7
8=pod
9
10This tests the classic diamond inheritance 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
40ok(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
45is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
46is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
47is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
48