t/mro/basic_01_dfs.t

   1 #!./perl
   2
   3 use strict;
   4 use warnings;
   5 BEGIN {
   6     unless (-d 'blib') {
   7         chdir 't' if -d 't';
   8         @INC = '../lib';
   9     }
  10 }
  11
  12 use Test::More tests => 4;
  13
  14 =pod
  15
  16 This tests the classic diamond inheritence pattern.
  17
  18    <A>
  19   /   \
  20 <B>   <C>
  21   \   /
  22    <D>
  23
  24 =cut
  25
  26 {
  27     package Diamond_A;
  28     sub hello { 'Diamond_A::hello' }
  29 }
  30 {
  31     package Diamond_B;
  32     use base 'Diamond_A';
  33 }
  34 {
  35     package Diamond_C;
  36     use base 'Diamond_A';
  37
  38     sub hello { 'Diamond_C::hello' }
  39 }
  40 {
  41     package Diamond_D;
  42     use base ('Diamond_B', 'Diamond_C');
  43     use mro 'dfs';
  44 }
  45
  46 is_deeply(
  47     mro::get_linear_isa('Diamond_D'),
  48     [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ],
  49     '... got the right MRO for Diamond_D');
  50
  51 is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
  52 is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
  53 is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');