t/mro/next_method.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 require q(./test.pl); plan(tests => 5);
   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     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
  48 ok(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
  53 is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
  54
  55 is(Diamond_D->can('hello')->('Diamond_D'),
  56    'Diamond_C::hello => Diamond_A::hello',
  57    '... can(method) resolved itself as expected');
  58
  59 is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'),
  60    'Diamond_C::hello => Diamond_A::hello',
  61    '... can(method) resolved itself as expected');
  62
  63 is(Diamond_D->foo,
  64     'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo',
  65     '... method foo resolved itself as expected');