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 ok(
  49     ClassWithRoleHCA->meta()->does_role('RoleHCA'),
  50     'ClassWithRoleHCA does RoleHCA'
  51 );
  52
  53 SharedTests::run_tests('ClassWithRoleHCA');
  54
  55 ClassWithRoleHCA->meta()->make_immutable();
  56
  57 ok(
  58     ClassWithRoleHCA->meta()->does_role('RoleHCA'),
  59     'ClassWithRoleHCA (immutable) does RoleHCA'
  60 );
  61
  62
  63 # These next tests are aimed at testing to-role application followed by
  64 # to-class application
  65 {
  66     package RoleWithRoleHCA;
  67
  68     use Moose::Role;
  69     use MooseX::ClassAttribute;
  70
  71     with 'RoleHCA';
  72 }
  73
  74 ok(
  75     RoleWithRoleHCA->meta()->does_role('RoleHCA'),
  76     'RoleWithRoleHCA does RoleHCA'
  77 );
  78
  79 {
  80     package ClassWithRoleWithRoleHCA;
  81
  82     use Moose;
  83
  84     with 'RoleWithRoleHCA';
  85
  86     has 'size' => (
  87         is      => 'rw',
  88         isa     => 'Int',
  89         default => 5,
  90     );
  91
  92     sub BUILD {
  93         my $self = shift;
  94
  95         $self->ObjectCount( $self->ObjectCount() + 1 );
  96     }
  97
  98     sub _BuildIt {42}
  99
 100     sub _CallTrigger {
 101         push @{ $_[0]->TriggerRecord() }, [@_];
 102     }
 103 }
 104
 105 ok(
 106     ClassWithRoleWithRoleHCA->meta()->does_role('RoleHCA'),
 107     'ClassWithRoleWithRoleHCA does RoleHCA'
 108 );
 109
 110 SharedTests::run_tests('ClassWithRoleWithRoleHCA');
 111
 112 ClassWithRoleWithRoleHCA->meta()->make_immutable();
 113
 114 ok(
 115     ClassWithRoleWithRoleHCA->meta()->does_role('RoleHCA'),
 116     'ClassWithRoleWithRoleHCA (immutable) does RoleHCA'
 117 );
 118
 119 {
 120     package InstanceWithRoleHCA;
 121
 122     use Moose;
 123
 124     has 'size' => (
 125         is      => 'rw',
 126         isa     => 'Int',
 127         default => 5,
 128     );
 129
 130     sub _BuildIt {42}
 131
 132     sub _CallTrigger {
 133         push @{ $_[0]->TriggerRecord() }, [@_];
 134     }
 135 }
 136
 137 my $instance = InstanceWithRoleHCA->new();
 138
 139 apply_all_roles( $instance, 'RoleHCA' );
 140
 141 ok(
 142     $instance->meta()->does_role('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 ok(
 153     $instance->meta()->does_role('RoleHCA'),
 154     '$instance (immutable) does RoleHCA'
 155 );
 156
 157 done_testing();