t/002_class_precedence_list.t

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