t/050-inherited-immutable-constructor-bug.t

   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