X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F041_metaclass_incompatibility.t;h=5148c29e9e4b16d8da4f8d2b5ff037a484e82827;hb=5e5102f19ccb1dc52b290577b0363e97dacbd5b3;hp=ac16bc16eb564163f55502eb2645b60d8ab9d538;hpb=6b0ff0b111b55fae95a1249cef77cfe2836f70a2;p=gitmo%2FClass-MOP.git

diff --git a/t/041_metaclass_incompatibility.t b/t/041_metaclass_incompatibility.t
index ac16bc1..5148c29 100644
--- a/t/041_metaclass_incompatibility.t
+++ b/t/041_metaclass_incompatibility.t
@@ -2,7 +2,7 @@ use strict;
 use warnings;
 
 use Test::More;
-use Test::Exception;
+use Test::Fatal;
 
 use metaclass;
 
@@ -32,79 +32,79 @@ for my $suffix ('Class', keys %metaclass_attrs) {
 
 # checking...
 
-lives_ok {
+is( exception {
     Foo::Meta::Class->create('Foo')
-} '... Foo.meta => Foo::Meta::Class is compatible';
-lives_ok {
+}, undef, '... Foo.meta => Foo::Meta::Class is compatible' );
+is( exception {
     Bar::Meta::Class->create('Bar')
-} '... Bar.meta => Bar::Meta::Class is compatible';
+}, undef, '... Bar.meta => Bar::Meta::Class is compatible' );
 
-throws_ok {
+like( exception {
     Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo'])
-} qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible';
-throws_ok {
+}, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' );
+like( exception {
     Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar'])
-} qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible';
+}, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' );
 
-lives_ok {
+is( exception {
     FooBar::Meta::Class->create('FooBar', superclasses => ['Foo'])
-} '... FooBar.meta => FooBar::Meta::Class is compatible';
-lives_ok {
+}, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' );
+is( exception {
     FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar'])
-} '... FooBar2.meta => FooBar::Meta::Class is compatible';
+}, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' );
 
 Foo::Meta::Class->create(
     'Foo::All',
     map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
 );
 
-throws_ok {
+like( exception {
     Bar::Meta::Class->create(
         'Foo::All::Sub::Class',
         superclasses => ['Foo::All'],
         map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
     )
-} qr/compatible/, 'incompatible Class metaclass';
+}, qr/compatible/, 'incompatible Class metaclass' );
 for my $suffix (keys %metaclass_attrs) {
-    throws_ok {
+    like( exception {
         Foo::Meta::Class->create(
             "Foo::All::Sub::$suffix",
             superclasses => ['Foo::All'],
             (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
             $metaclass_attrs{$suffix} => "Bar::Meta::$suffix",
         )
-    } qr/compatible/, "incompatible $suffix metaclass";
+    }, qr/compatible/, "incompatible $suffix metaclass" );
 }
 
 # fixing...
 
-lives_ok {
+is( exception {
     Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo'])
-} 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass';
+}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' );
 isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class');
-lives_ok {
+is( exception {
     Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar'])
-} 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass';
+}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' );
 isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class');
 
-lives_ok {
+is( exception {
     Class::MOP::Class->create(
         'Foo::All::Sub::CMOP::Class',
         superclasses => ['Foo::All'],
         map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
     )
-} 'metaclass fixing works with other non-default metaclasses';
+}, undef, 'metaclass fixing works with other non-default metaclasses' );
 isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class');
 
 for my $suffix (keys %metaclass_attrs) {
-    lives_ok {
+    is( exception {
         Foo::Meta::Class->create(
             "Foo::All::Sub::CMOP::$suffix",
             superclasses => ['Foo::All'],
             (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs),
             $metaclass_attrs{$suffix} => "Class::MOP::$suffix",
         )
-    } "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses";
+    }, undef, "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses" );
     for my $suffix2 (keys %metaclass_attrs) {
         my $method = $metaclass_attrs{$suffix2};
         isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2");
@@ -172,7 +172,7 @@ Foo::Meta::Class->create(
     'Foo::Reverse',
 );
 isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class');
-{ local $TODO = "no idea how to handle this";
+{ local $TODO = 'No idea how to handle case where parent class is created before children';
 isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class');
 isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class');
 }
@@ -188,9 +188,69 @@ isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class');
         'Foo::Unsafe::Sub',
     );
     $meta->add_attribute(foo => reader => 'foo');
-    throws_ok { $meta->superclasses('Foo::Unsafe') }
-              qr/compatibility.*pristine/,
-              "can't switch out the attribute metaclass of a class that already has attributes";
+    like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" );
 }
 
+# immutability...
+
+{
+    my $foometa = Foo::Meta::Class->create(
+        'Foo::Immutable',
+    );
+    $foometa->make_immutable;
+    my $barmeta = Class::MOP::Class->create(
+        'Bar::Mutable',
+    );
+    my $bazmeta = Class::MOP::Class->create(
+        'Baz::Mutable',
+    );
+    $bazmeta->superclasses($foometa->name);
+    is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" );
+    ok(!$bazmeta->is_immutable,
+       "immutable superclass doesn't make this class immutable");
+    is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" );
+}
+
+# nonexistent metaclasses
+
+Class::MOP::Class->create(
+    'Weird::Meta::Method::Destructor',
+    superclasses => ['Class::MOP::Method'],
+);
+
+is( exception {
+    Class::MOP::Class->create(
+        'Weird::Class',
+        destructor_class => 'Weird::Meta::Method::Destructor',
+    );
+}, undef, "defined metaclass in child with defined metaclass in parent is fine" );
+
+is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor',
+   "got the right destructor class");
+
+is( exception {
+    Class::MOP::Class->create(
+        'Weird::Class::Sub',
+        superclasses     => ['Weird::Class'],
+        destructor_class => undef,
+    );
+}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
+
+is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
+   "got the right destructor class");
+
+is( exception {
+    Class::MOP::Class->create(
+        'Weird::Class::Sub2',
+        destructor_class => undef,
+    );
+}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
+
+is( exception {
+    Weird::Class::Sub2->meta->superclasses('Weird::Class');
+}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
+
+is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
+   "got the right destructor class");
+
 done_testing;