#!/usr/bin/perl
use strict;
use warnings;
use Test::More tests => 3;
use Test::Exception;
=pod
This test checks a number of different bad heirarchies.
=cut
use Perl6::MetaModel;
=pod
Somewhat convoluted multiple inheritance, with
some repeated inheritance as well.
::Object
^ ^
/ |
Foo |
^ ^ |
| \ |
| Bar |
| ^ |
| / |
FooBar Baz
\ /
FooBarBaz
=cut
my $Foo = class 'Foo' => { is => [ $::Object ] };
my $Bar = class 'Bar' => { is => [ $Foo ] };
my $Baz = class 'Baz' => { is => [ $::Object ] };
throws_ok {
class 'FooBar' => {
is => [ $Foo, $Bar ]
};
} qr/Inconsistent hierarchy/, '... this should die';
=pod
Expanded diamond inheritance with repeated more repeats
+---------+
| A |
| / \ |
+--B C |
| / | |
| / |/
D E
\ /
F
=cut
my $Diamond_A = class 'Diamond_A' => { is => [ $::Object ] };
my $Diamond_B = class 'Diamond_B' => {
is => [ $Diamond_A ]
};
my $Diamond_C = class 'Diamond_C' => {
is => [ $Diamond_A ]
};
my $Diamond2_D = class 'Diamond2_D' => {
is => [ $Diamond_B, $Diamond_C ]
};
my $Diamond2_E = class 'Diamond2_E' => {
is => [ $Diamond_C, $Diamond_B ]
};
throws_ok {
class 'Diamond2_F' => {
is => [ $Diamond2_D, $Diamond2_E ]
};
} qr/Inconsistent hierarchy/, '... this should die';
=pod
circular inheritence
+-- B <-+
| |
+-> A --+
=cut
my $B = class 'B' => { is => [ $::Object ] };
my $A = class 'A' => { is => [ $B ] };
throws_ok {
$B->superclasses([ $::Object, $A ]);
} qr/Inconsistent hierarchy/, '... this should die';