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 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 =pod
  40
  41  A <-+
  42  |   |
  43  B   |
  44  |   |
  45  C --+
  46
  47 =cut
  48
  49 # 5.9.5+ dies at the moment of
  50 # recursive @ISA definition, not later when
  51 # you try to use the @ISAs.
  52 eval {
  53     {
  54         package My::2::A;
  55         use metaclass;
  56         our @ISA = ('My::2::C');
  57
  58         package My::2::B;
  59         our @ISA = ('My::2::A');
  60
  61         package My::2::C;
  62         our @ISA = ('My::2::B');
  63     }
  64
  65     My::2::B->meta->class_precedence_list
  66 };
  67 ok($@, '... recursive inheritance breaks correctly :)');
  68
  69 =pod
  70
  71  +--------+
  72  |    A   |
  73  |   / \  |
  74  +->B   C-+
  75      \ /
  76       D
  77
  78 =cut
  79
  80 {
  81     package My::3::A;
  82     use metaclass;
  83     package My::3::B;
  84     our @ISA = ('My::3::A');
  85     package My::3::C;
  86     our @ISA = ('My::3::A', 'My::3::B');
  87     package My::3::D;
  88     our @ISA = ('My::3::B', 'My::3::C');
  89 }
  90
  91 is_deeply(
  92     [ My::3::D->meta->class_precedence_list ],
  93     [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ],
  94     '... My::3::D->meta->class_precedence_list == (D B A C A B A)');
  95
  96 =pod
  97
  98 Test all the class_precedence_lists
  99 using Perl's own dispatcher to check
 100 against.
 101
 102 =cut
 103
 104 my @CLASS_PRECEDENCE_LIST;
 105
 106 {
 107     package Foo;
 108     use metaclass;
 109
 110     sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' }
 111
 112     package Bar;
 113     our @ISA = ('Foo');
 114
 115     sub CPL {
 116         push @CLASS_PRECEDENCE_LIST => 'Bar';
 117         $_[0]->SUPER::CPL();
 118     }
 119
 120     package Baz;
 121     use metaclass;
 122     our @ISA = ('Bar');
 123
 124     sub CPL {
 125         push @CLASS_PRECEDENCE_LIST => 'Baz';
 126         $_[0]->SUPER::CPL();
 127     }
 128
 129     package Foo::Bar;
 130     our @ISA = ('Baz');
 131
 132     sub CPL {
 133         push @CLASS_PRECEDENCE_LIST => 'Foo::Bar';
 134         $_[0]->SUPER::CPL();
 135     }
 136
 137     package Foo::Bar::Baz;
 138     our @ISA = ('Foo::Bar');
 139
 140     sub CPL {
 141         push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz';
 142         $_[0]->SUPER::CPL();
 143     }
 144
 145 }
 146
 147 Foo::Bar::Baz->CPL();
 148
 149 is_deeply(
 150     [ Foo::Bar::Baz->meta->class_precedence_list ],
 151     [ @CLASS_PRECEDENCE_LIST ],
 152     '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST');
 153