Commit | Line | Data |
ae7bec5e |
1 | #!/usr/bin/perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More tests => 8; |
5 | |
6 | { |
7 | package Sausage; |
8 | use Mouse::Role; |
9 | |
10 | has gristle => (is => 'rw'); |
11 | } |
12 | |
13 | { |
14 | package Dog; |
15 | use Mouse; |
16 | |
17 | has tail => (is => 'rw'); |
18 | |
19 | __PACKAGE__->meta->make_immutable; |
20 | } |
21 | |
22 | { |
23 | package SausageDog; |
24 | use Mouse; |
25 | extends 'Dog'; |
26 | with 'Sausage'; |
27 | |
28 | has yap => (is => 'rw'); |
29 | |
30 | # This class is mutable, but derives from an immutable base, and so |
31 | # used to inherit an immutable constructor compiled for the wrong |
32 | # class. It is composed with a Role, and should acquire both the |
33 | # attributes in that role, and the initialisers. Likewise for it's own |
34 | # attributes. (In the bug this test exhibited, it wasn't acquiring an |
35 | # initialiser for 'gristle' or 'yap'). |
36 | # |
37 | # This has now been fixed by adding a check in the immutable |
38 | # constructor that the invoking class is the right one, else it |
39 | # redispatches to Mouse::Object::new. |
40 | } |
41 | |
42 | |
43 | |
44 | |
45 | my $fritz = SausageDog->new(gristle => 1, |
46 | tail => 1, |
47 | yap => 1); |
48 | |
49 | |
50 | isa_ok $fritz, 'SausageDog'; |
51 | isa_ok $fritz, 'Dog'; |
52 | ok !$fritz->isa('Sausage'), "Fritz is not a Sausage"; |
53 | ok $fritz->does('Sausage'), "Fritz does Sausage"; |
54 | |
55 | can_ok $fritz, qw(tail gristle yap); |
56 | |
57 | ok $fritz->gristle, "Fritz has gristle"; |
58 | ok $fritz->tail, "Fritz has a tail"; |
59 | ok $fritz->yap, "Fritz has a yap"; |
60 | |
61 | |
62 | |