t/cmop/metaclass_incompatibility.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 use metaclass;
   8
   9 my %metaclass_attrs = (
  10     'Instance'            => 'instance_metaclass',
  11     'Attribute'           => 'attribute_metaclass',
  12     'Method'              => 'method_metaclass',
  13     'Method::Wrapped'     => 'wrapped_method_metaclass',
  14     'Method::Constructor' => 'constructor_class',
  15 );
  16
  17 # meta classes
  18 for my $suffix ('Class', keys %metaclass_attrs) {
  19     Class::MOP::Class->create(
  20         "Foo::Meta::$suffix",
  21         superclasses => ["Class::MOP::$suffix"]
  22     );
  23     Class::MOP::Class->create(
  24         "Bar::Meta::$suffix",
  25         superclasses => ["Class::MOP::$suffix"]
  26     );
  27     Class::MOP::Class->create(
  28         "FooBar::Meta::$suffix",
  29         superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"]
  30     );
  31 }
  32
  33 # checking...
  34
  35 is( exception {
  36     Foo::Meta::Class->create('Foo')
  37 }, undef, '... Foo.meta => Foo::Meta::Class is compatible' );
  38 is( exception {
  39     Bar::Meta::Class->create('Bar')
  40 }, undef, '... Bar.meta => Bar::Meta::Class is compatible' );
  41
  42 like( exception {
  43     Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo'])
  44 }, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' );
  45 like( exception {
  46     Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar'])
  47 }, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' );
  48
  49 is( exception {
  50     FooBar::Meta::Class->create('FooBar', superclasses => ['Foo'])
  51 }, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' );
  52 is( exception {
  53     FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar'])
  54 }, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' );
  55
  56 Foo::Meta::Class->create(
  57     'Foo::All',
  58     map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
  59 );
  60
  61 like( exception {
  62     Bar::Meta::Class->create(
  63         'Foo::All::Sub::Class',
  64         superclasses => ['Foo::All'],
  65         map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
  66     )
  67 }, qr/compatible/, 'incompatible Class metaclass' );
  68 for my $suffix (keys %metaclass_attrs) {
  69     like( exception {
  70         Foo::Meta::Class->create(
  71             "Foo::All::Sub::$suffix",
  72             superclasses => ['Foo::All'],
  73             (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
  74             $metaclass_attrs{$suffix} => "Bar::Meta::$suffix",
  75         )
  76     }, qr/compatible/, "incompatible $suffix metaclass" );
  77 }
  78
  79 # fixing...
  80
  81 is( exception {
  82     Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo'])
  83 }, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' );
  84 isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class');
  85 is( exception {
  86     Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar'])
  87 }, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' );
  88 isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class');
  89
  90 is( exception {
  91     Class::MOP::Class->create(
  92         'Foo::All::Sub::CMOP::Class',
  93         superclasses => ['Foo::All'],
  94         map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
  95     )
  96 }, undef, 'metaclass fixing works with other non-default metaclasses' );
  97 isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class');
  98
  99 for my $suffix (keys %metaclass_attrs) {
 100     is( exception {
 101         Foo::Meta::Class->create(
 102             "Foo::All::Sub::CMOP::$suffix",
 103             superclasses => ['Foo::All'],
 104             (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
 105             $metaclass_attrs{$suffix} => "Class::MOP::$suffix",
 106         )
 107     }, undef, "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses" );
 108     for my $suffix2 (keys %metaclass_attrs) {
 109         my $method = $metaclass_attrs{$suffix2};
 110         isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2");
 111     }
 112 }
 113
 114 # initializing...
 115
 116 {
 117     package Foo::NoMeta;
 118 }
 119
 120 Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']);
 121 ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
 122 isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class');
 123 isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class');
 124
 125 {
 126     package Foo::NoMeta2;
 127 }
 128 Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']);
 129 ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed");
 130 isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class');
 131 isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class');
 132
 133 Foo::Meta::Class->create('Foo::WithMeta');
 134 {
 135     package Foo::WithMeta::Sub;
 136     use base 'Foo::WithMeta';
 137 }
 138 Class::MOP::Class->create(
 139     'Foo::WithMeta::Sub::Sub',
 140     superclasses => ['Foo::WithMeta::Sub']
 141 );
 142
 143 isa_ok(Class::MOP::class_of('Foo::WithMeta'), 'Foo::Meta::Class');
 144 isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub'), 'Foo::Meta::Class');
 145 isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub::Sub'), 'Foo::Meta::Class');
 146
 147 Foo::Meta::Class->create('Foo::WithMeta2');
 148 {
 149     package Foo::WithMeta2::Sub;
 150     use base 'Foo::WithMeta2';
 151 }
 152 {
 153     package Foo::WithMeta2::Sub::Sub;
 154     use base 'Foo::WithMeta2::Sub';
 155 }
 156 Class::MOP::Class->create(
 157     'Foo::WithMeta2::Sub::Sub::Sub',
 158     superclasses => ['Foo::WithMeta2::Sub::Sub']
 159 );
 160
 161 isa_ok(Class::MOP::class_of('Foo::WithMeta2'), 'Foo::Meta::Class');
 162 isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub'), 'Foo::Meta::Class');
 163 isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub'), 'Foo::Meta::Class');
 164 isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub::Sub'), 'Foo::Meta::Class');
 165
 166 Class::MOP::Class->create(
 167     'Foo::Reverse::Sub::Sub',
 168     superclasses => ['Foo::Reverse::Sub'],
 169 );
 170 eval "package Foo::Reverse::Sub; use base 'Foo::Reverse';";
 171 Foo::Meta::Class->create(
 172     'Foo::Reverse',
 173 );
 174 isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class');
 175 { local $TODO = 'No idea how to handle case where child class is created before parent';
 176 isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class');
 177 isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class');
 178 }
 179
 180 # unsafe fixing...
 181
 182 {
 183     Class::MOP::Class->create(
 184         'Foo::Unsafe',
 185         attribute_metaclass => 'Foo::Meta::Attribute',
 186     );
 187     my $meta = Class::MOP::Class->create(
 188         'Foo::Unsafe::Sub',
 189     );
 190     $meta->add_attribute(foo => reader => 'foo');
 191     like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" );
 192 }
 193
 194 # immutability...
 195
 196 {
 197     my $foometa = Foo::Meta::Class->create(
 198         'Foo::Immutable',
 199     );
 200     $foometa->make_immutable;
 201     my $barmeta = Class::MOP::Class->create(
 202         'Bar::Mutable',
 203     );
 204     my $bazmeta = Class::MOP::Class->create(
 205         'Baz::Mutable',
 206     );
 207     $bazmeta->superclasses($foometa->name);
 208     is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" );
 209     ok(!$bazmeta->is_immutable,
 210        "immutable superclass doesn't make this class immutable");
 211     is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" );
 212 }
 213
 214 # nonexistent metaclasses
 215
 216 Class::MOP::Class->create(
 217     'Weird::Meta::Method::Destructor',
 218     superclasses => ['Class::MOP::Method'],
 219 );
 220
 221 is( exception {
 222     Class::MOP::Class->create(
 223         'Weird::Class',
 224         destructor_class => 'Weird::Meta::Method::Destructor',
 225     );
 226 }, undef, "defined metaclass in child with defined metaclass in parent is fine" );
 227
 228 is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor',
 229    "got the right destructor class");
 230
 231 is( exception {
 232     Class::MOP::Class->create(
 233         'Weird::Class::Sub',
 234         superclasses     => ['Weird::Class'],
 235         destructor_class => undef,
 236     );
 237 }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
 238
 239 is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
 240    "got the right destructor class");
 241
 242 is( exception {
 243     Class::MOP::Class->create(
 244         'Weird::Class::Sub2',
 245         destructor_class => undef,
 246     );
 247 }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
 248
 249 is( exception {
 250     Weird::Class::Sub2->meta->superclasses('Weird::Class');
 251 }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
 252
 253 is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
 254    "got the right destructor class");
 255
 256 done_testing;