t/06-role.t

   1 use strict;
   2 use warnings;
   3
   4 use lib 't/lib';
   5
   6 use SharedTests;
   7 use Test::More;
   8
   9 use Moose::Util qw( apply_all_roles );
  10
  11 {
  12     package RoleHCA;
  13
  14     use Moose::Role;
  15     use MooseX::ClassAttribute;
  16
  17     while ( my ( $name, $def ) = each %SharedTests::Attrs ) {
  18         class_has $name => %{$def};
  19     }
  20 }
  21
  22 {
  23     package ClassWithRoleHCA;
  24
  25     use Moose;
  26
  27     with 'RoleHCA';
  28
  29     has 'size' => (
  30         is      => 'rw',
  31         isa     => 'Int',
  32         default => 5,
  33     );
  34
  35     sub BUILD {
  36         my $self = shift;
  37
  38         $self->ObjectCount( $self->ObjectCount() + 1 );
  39     }
  40
  41     sub _BuildIt {42}
  42
  43     sub _CallTrigger {
  44         push @{ $_[0]->TriggerRecord() }, [@_];
  45     }
  46 }
  47
  48 is_deeply(
  49     [ map { $_->name() } ClassWithRoleHCA->meta()->calculate_all_roles() ],
  50     ['RoleHCA'],
  51     'ClassWithRoleHCA does RoleHCA'
  52 );
  53
  54 SharedTests::run_tests('ClassWithRoleHCA');
  55
  56 ClassWithRoleHCA->meta()->make_immutable();
  57
  58 is_deeply(
  59     [ map { $_->name() } ClassWithRoleHCA->meta()->calculate_all_roles() ],
  60     ['RoleHCA'],
  61     'ClassWithRoleHCA (immutable) does RoleHCA'
  62 );
  63
  64
  65 # These next tests are aimed at testing to-role application followed by
  66 # to-class application
  67 {
  68     package RoleWithRoleHCA;
  69
  70     use Moose::Role;
  71     use MooseX::ClassAttribute;
  72
  73     with 'RoleHCA';
  74 }
  75
  76 {
  77     package ClassWithRoleWithRoleHCA;
  78
  79     use Moose;
  80
  81     with 'RoleWithRoleHCA';
  82
  83     has 'size' => (
  84         is      => 'rw',
  85         isa     => 'Int',
  86         default => 5,
  87     );
  88
  89     sub BUILD {
  90         my $self = shift;
  91
  92         $self->ObjectCount( $self->ObjectCount() + 1 );
  93     }
  94
  95     sub _BuildIt {42}
  96
  97     sub _CallTrigger {
  98         push @{ $_[0]->TriggerRecord() }, [@_];
  99     }
 100 }
 101
 102 is_deeply(
 103     [ map { $_->name() } ClassWithRoleHCA->meta()->calculate_all_roles() ],
 104     ['RoleHCA'],
 105     'ClassWithRoleWithRoleHCA does RoleHCA'
 106 );
 107
 108 SharedTests::run_tests('ClassWithRoleWithRoleHCA');
 109
 110 ClassWithRoleWithRoleHCA->meta()->make_immutable();
 111
 112 is_deeply(
 113     [ map { $_->name() } ClassWithRoleHCA->meta()->calculate_all_roles() ],
 114     ['RoleHCA'],
 115     'ClassWithRoleWithRoleHCA (immutable) does RoleHCA'
 116 );
 117
 118 {
 119     package InstanceWithRoleHCA;
 120
 121     use Moose;
 122
 123     has 'size' => (
 124         is      => 'rw',
 125         isa     => 'Int',
 126         default => 5,
 127     );
 128
 129     sub _BuildIt {42}
 130
 131     sub _CallTrigger {
 132         push @{ $_[0]->TriggerRecord() }, [@_];
 133     }
 134 }
 135
 136 my $instance = InstanceWithRoleHCA->new();
 137
 138 apply_all_roles( $instance, 'RoleHCA' );
 139
 140 is_deeply(
 141     [ map { $_->name() } $instance->meta()->calculate_all_roles() ],
 142     ['RoleHCA'],
 143     '$instance does RoleHCA'
 144 );
 145
 146 $instance->ObjectCount(1);
 147
 148 SharedTests::run_tests($instance);
 149
 150 $instance->meta()->make_immutable();
 151
 152 is_deeply(
 153     [ map { $_->name() } $instance->meta()->calculate_all_roles() ],
 154     ['RoleHCA'],
 155     '$instance (immutable) does RoleHCA'
 156 );
 157
 158 done_testing();