t/041_metaclass_incompatibility.t

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