t/30_next_method.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4;
   7
   8 use Class::C3::XS;
   9
  10 =pod
  11
  12 This tests the classic diamond inheritence pattern.
  13
  14    <A>
  15   /   \
  16 <B>   <C>
  17   \   /
  18    <D>
  19
  20 =cut
  21
  22 {
  23     package Diamond_A;
  24     sub hello { 'Diamond_A::hello' }
  25     sub foo { 'Diamond_A::foo' }
  26 }
  27 {
  28     package Diamond_B;
  29     use base 'Diamond_A';
  30     sub foo { 'Diamond_B::foo => ' . (shift)->next::method() }
  31 }
  32 {
  33     package Diamond_C;
  34     use base 'Diamond_A';
  35
  36     sub hello { 'Diamond_C::hello => ' . (shift)->next::method() }
  37     sub foo { 'Diamond_C::foo => ' . (shift)->next::method() }
  38 }
  39 {
  40     package Diamond_D;
  41     use base ('Diamond_B', 'Diamond_C');
  42
  43     sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
  44 }
  45
  46 is(Diamond_C->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
  47
  48 is(Diamond_C->can('hello')->('Diamond_C'),
  49    'Diamond_C::hello => Diamond_A::hello',
  50    '... can(method) resolved itself as expected');
  51
  52 is(UNIVERSAL::can("Diamond_C", 'hello')->('Diamond_C'),
  53    'Diamond_C::hello => Diamond_A::hello',
  54    '... can(method) resolved itself as expected');
  55
  56 is(Diamond_D->foo,
  57     'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo',
  58     '... method foo resolved itself as expected');