xref: /openbsd/gnu/usr.bin/perl/t/mro/next_method.t (revision 898184e3) 
1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6require q(./test.pl); plan(tests => 5);
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    use mro 'c3';
23    sub hello { 'Diamond_A::hello' }
24    sub foo { 'Diamond_A::foo' }
25}
26{
27    package Diamond_B;
28    use base 'Diamond_A';
29    use mro 'c3';
30    sub foo { 'Diamond_B::foo => ' . (shift)->next::method() }
31}
32{
33    package Diamond_C;
34    use mro 'c3';
35    use base 'Diamond_A';
36
37    sub hello { 'Diamond_C::hello => ' . (shift)->next::method() }
38    sub foo { 'Diamond_C::foo => ' . (shift)->next::method() }
39}
40{
41    package Diamond_D;
42    use base ('Diamond_B', 'Diamond_C');
43    use mro 'c3';
44
45    sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
46}
47
48ok(eq_array(
49    mro::get_linear_isa('Diamond_D'),
50    [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ]
51), '... got the right MRO for Diamond_D');
52
53is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
54
55is(Diamond_D->can('hello')->('Diamond_D'),
56   'Diamond_C::hello => Diamond_A::hello',
57   '... can(method) resolved itself as expected');
58
59is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'),
60   'Diamond_C::hello => Diamond_A::hello',
61   '... can(method) resolved itself as expected');
62
63is(Diamond_D->foo,
64    'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo',
65    '... method foo resolved itself as expected');
66