t/002_class_precedence_list.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 6;
   7
   8 use Class::MOP;
   9 use Class::MOP::Class;
  10
  11 =pod
  12
  13   A
  14  / \
  15 B   C
  16  \ /
  17   D
  18
  19 =cut
  20
  21 {
  22     package My::A;
  23     use metaclass;
  24     package My::B;
  25     our @ISA = ('My::A');
  26     package My::C;
  27     our @ISA = ('My::A');
  28     package My::D;
  29     our @ISA = ('My::B', 'My::C');
  30 }
  31
  32 is_deeply(
  33     [ My::D->meta->class_precedence_list ],
  34     [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ],
  35     '... My::D->meta->class_precedence_list == (D B A C A)');
  36
  37 is_deeply(
  38     [ My::D->meta->linearized_isa ],
  39     [ 'My::D', 'My::B', 'My::A', 'My::C' ],
  40     '... My::D->meta->linearized_isa == (D B A C)');
  41
  42 =pod
  43
  44  A <-+
  45  |   |
  46  B   |
  47  |   |
  48  C --+
  49
  50 =cut
  51
  52 # 5.9.5+ dies at the moment of
  53 # recursive @ISA definition, not later when
  54 # you try to use the @ISAs.
  55 eval {
  56     {
  57         package My::2::A;
  58         use metaclass;
  59         our @ISA = ('My::2::C');
  60
  61         package My::2::B;
  62         our @ISA = ('My::2::A');
  63
  64         package My::2::C;
  65         our @ISA = ('My::2::B');
  66     }
  67
  68     My::2::B->meta->class_precedence_list
  69 };
  70 ok($@, '... recursive inheritance breaks correctly :)');
  71
  72 =pod
  73
  74  +--------+
  75  |    A   |
  76  |   / \  |
  77  +->B   C-+
  78      \ /
  79       D
  80
  81 =cut
  82
  83 {
  84     package My::3::A;
  85     use metaclass;
  86     package My::3::B;
  87     our @ISA = ('My::3::A');
  88     package My::3::C;
  89     our @ISA = ('My::3::A', 'My::3::B');
  90     package My::3::D;
  91     our @ISA = ('My::3::B', 'My::3::C');
  92 }
  93
  94 is_deeply(
  95     [ My::3::D->meta->class_precedence_list ],
  96     [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ],
  97     '... My::3::D->meta->class_precedence_list == (D B A C A B A)');
  98
  99 is_deeply(
 100     [ My::3::D->meta->linearized_isa ],
 101     [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ],
 102     '... My::3::D->meta->linearized_isa == (D B A C B)');
 103
 104 =pod
 105
 106 Test all the class_precedence_lists
 107 using Perl's own dispatcher to check
 108 against.
 109
 110 =cut
 111
 112 my @CLASS_PRECEDENCE_LIST;
 113
 114 {
 115     package Foo;
 116     use metaclass;
 117
 118     sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' }
 119
 120     package Bar;
 121     our @ISA = ('Foo');
 122
 123     sub CPL {
 124         push @CLASS_PRECEDENCE_LIST => 'Bar';
 125         $_[0]->SUPER::CPL();
 126     }
 127
 128     package Baz;
 129     use metaclass;
 130     our @ISA = ('Bar');
 131
 132     sub CPL {
 133         push @CLASS_PRECEDENCE_LIST => 'Baz';
 134         $_[0]->SUPER::CPL();
 135     }
 136
 137     package Foo::Bar;
 138     our @ISA = ('Baz');
 139
 140     sub CPL {
 141         push @CLASS_PRECEDENCE_LIST => 'Foo::Bar';
 142         $_[0]->SUPER::CPL();
 143     }
 144
 145     package Foo::Bar::Baz;
 146     our @ISA = ('Foo::Bar');
 147
 148     sub CPL {
 149         push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz';
 150         $_[0]->SUPER::CPL();
 151     }
 152
 153 }
 154
 155 Foo::Bar::Baz->CPL();
 156
 157 is_deeply(
 158     [ Foo::Bar::Baz->meta->class_precedence_list ],
 159     [ @CLASS_PRECEDENCE_LIST ],
 160     '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST');
 161