t/300_immutable/006_immutable_nonmoose_subclass.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 8;
   7 use Test::Exception;
   8 use Scalar::Util 'blessed';
   9
  10 =pod
  11
  12 This test it kind of odd, it tests
  13 to see if make_immutable will DWIM
  14 when pressented with a class that
  15 inherits from a non-Moose base class.
  16
  17 Since immutable only affects the local
  18 class, and if it doesnt find a constructor
  19 it will always create one, it won't
  20 discover this issue, and it will ignore
  21 the inherited constructor.
  22
  23 This is not really the desired way, but
  24 detecting this opens a big can of worms
  25 which we are not going to deal with just
  26 yet (eventually yes, but most likely it
  27 will be when we have MooseX::Compile
  28 available and working).
  29
  30 In the meantime, just know that when you
  31 call make_immutable on a class which
  32 inherits from a non-Moose class, you
  33 should add (inline_constructor => 0).
  34
  35 Sorry Sartak.
  36
  37 =cut
  38
  39 {
  40     package Grandparent;
  41
  42     sub new {
  43         my $class = shift;
  44         my %args  = (
  45             grandparent => 'gramma',
  46             @_,
  47         );
  48
  49         bless \%args => $class;
  50     }
  51
  52     sub grandparent { 1 }
  53 }
  54
  55 {
  56     package Parent;
  57     use Moose;
  58     extends 'Grandparent';
  59
  60     around new => sub {
  61         my $orig  = shift;
  62         my $class = shift;
  63
  64         $class->$orig(
  65             parent => 'mama',
  66             @_,
  67         );
  68     };
  69
  70     sub parent { 1 }
  71 }
  72
  73 {
  74     package Child;
  75     use Moose;
  76     extends 'Parent';
  77
  78     sub child { 1 }
  79
  80     __PACKAGE__->meta->make_immutable;
  81 }
  82
  83 is(blessed(Grandparent->new), "Grandparent", "got a Grandparent object out of Grandparent->new");
  84 is(blessed(Parent->new), "Parent", "got a Parent object out of Parent->new");
  85 is(blessed(Child->new), "Child", "got a Child object out of Child->new");
  86
  87 is(Child->new->grandparent, 1, "Child responds to grandparent");
  88 is(Child->new->parent, 1, "Child responds to parent");
  89 is(Child->new->child, 1, "Child responds to child");
  90
  91 is(Child->new->{grandparent}, undef, "didnt create a value, cause immutable overode the constructor");
  92 is(Child->new->{parent}, undef, "didnt create a value, cause immutable overode the constructor");
  93
  94