t/30_next_method.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More 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 Class::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 Class::C3;
  30     sub foo { 'Diamond_B::foo => ' . (shift)->next::method() }
  31 }
  32 {
  33     package Diamond_C;
  34     use Class::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 Class::C3;
  44
  45     sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
  46 }
  47
  48 Class::C3::initialize();
  49
  50 is_deeply(
  51     [ Class::C3::calculateMRO('Diamond_D') ],
  52     [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
  53     '... got the right MRO for Diamond_D');
  54
  55 is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
  56
  57 is(Diamond_D->can('hello')->('Diamond_D'),
  58    'Diamond_C::hello => Diamond_A::hello',
  59    '... can(method) resolved itself as expected');
  60
  61 is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'),
  62    'Diamond_C::hello => Diamond_A::hello',
  63    '... can(method) resolved itself as expected');
  64
  65 is(Diamond_D->foo,
  66     'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo',
  67     '... method foo resolved itself as expected');