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 => 10;
   7 use Test::Exception;
   8 use Scalar::Util 'blessed';
   9
  10 BEGIN {
  11     use_ok('Moose');
  12     use_ok('Moose::Meta::Role');
  13 }
  14
  15 {
  16     package Grandparent;
  17
  18     sub new {
  19         my $class = shift;
  20         my %args  = (
  21             grandparent => 'gramma',
  22             @_,
  23         );
  24
  25         bless \%args => $class;
  26     }
  27
  28     sub grandparent { 1 }
  29 }
  30
  31 {
  32     package Parent;
  33     use Moose;
  34     extends 'Grandparent';
  35
  36     around new => sub {
  37         my $orig  = shift;
  38         my $class = shift;
  39
  40         $class->$orig(
  41             parent => 'mama',
  42             @_,
  43         );
  44     };
  45
  46     sub parent { 1 }
  47 }
  48
  49 {
  50     package Child;
  51     use Moose;
  52     extends 'Parent';
  53
  54     sub child { 1 }
  55
  56     make_immutable;
  57 }
  58
  59 is(blessed(Grandparent->new), "Grandparent", "got a Grandparent object out of Grandparent->new");
  60 is(blessed(Parent->new), "Parent", "got a Parent object out of Parent->new");
  61 is(blessed(Child->new), "Child", "got a Child object out of Child->new");
  62
  63 is(Child->new->grandparent, 1, "Child responds to grandparent");
  64 is(Child->new->parent, 1, "Child responds to parent");
  65 is(Child->new->child, 1, "Child responds to child");
  66
  67 is(Child->new->{grandparent}, 'gramma', "Instance structure has attributes");
  68 is(Child->new->{parent}, 'mama', "Parent's 'around' is respected");
  69