t/050_metaclasses/013_metaclass_traits.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib', 'lib';
   7
   8 use Test::More tests => 32;
   9 use Test::Exception;
  10
  11 {
  12     package My::SimpleTrait;
  13
  14     use Mouse::Role;
  15
  16     sub simple { return 5 }
  17 }
  18
  19 {
  20     package Foo;
  21
  22     use Mouse -traits => [ 'My::SimpleTrait' ];
  23 }
  24
  25 can_ok( Foo->meta(), 'simple' );
  26 is( Foo->meta()->simple(), 5,
  27     'Foo->meta()->simple() returns expected value' );
  28
  29 {
  30     package Bar;
  31
  32     use Mouse -traits => 'My::SimpleTrait';
  33 }
  34
  35 can_ok( Bar->meta(), 'simple' );
  36 is( Bar->meta()->simple(), 5,
  37     'Foo->meta()->simple() returns expected value' );
  38
  39 {
  40     package My::SimpleTrait2;
  41
  42     use Mouse::Role;
  43
  44     # This needs to happen at compile time so it happens before we
  45     # apply traits to Bar
  46     BEGIN {
  47         has 'attr' =>
  48             ( is      => 'ro',
  49               default => 'something',
  50             );
  51     }
  52
  53     sub simple { return 5 }
  54 }
  55
  56 {
  57     package Bar;
  58
  59     use Mouse -traits => [ 'My::SimpleTrait2' ];
  60 }
  61
  62 can_ok( Bar->meta(), 'simple' );
  63 is( Bar->meta()->simple(), 5,
  64     'Bar->meta()->simple() returns expected value' );
  65 can_ok( Bar->meta(), 'attr' );
  66 is( Bar->meta()->attr(), 'something',
  67     'Bar->meta()->attr() returns expected value' );
  68
  69 {
  70     package My::SimpleTrait3;
  71
  72     use Mouse::Role;
  73
  74     BEGIN {
  75         has 'attr2' =>
  76             ( is      => 'ro',
  77               default => 'something',
  78             );
  79     }
  80
  81     sub simple2 { return 55 }
  82 }
  83
  84 {
  85     package Baz;
  86
  87     use Mouse -traits => [ 'My::SimpleTrait2', 'My::SimpleTrait3' ];
  88 }
  89
  90 can_ok( Baz->meta(), 'simple' );
  91 is( Baz->meta()->simple(), 5,
  92     'Baz->meta()->simple() returns expected value' );
  93 can_ok( Baz->meta(), 'attr' );
  94 is( Baz->meta()->attr(), 'something',
  95     'Baz->meta()->attr() returns expected value' );
  96 can_ok( Baz->meta(), 'simple2' );
  97 is( Baz->meta()->simple2(), 55,
  98     'Baz->meta()->simple2() returns expected value' );
  99 can_ok( Baz->meta(), 'attr2' );
 100 is( Baz->meta()->attr2(), 'something',
 101     'Baz->meta()->attr2() returns expected value' );
 102
 103 {
 104     package My::Trait::AlwaysRO;
 105
 106     use Mouse::Role;
 107
 108     around '_process_new_attribute', '_process_inherited_attribute' =>
 109         sub {
 110             my $orig = shift;
 111             my ( $self, $name, %args ) = @_;
 112
 113             $args{is} = 'ro';
 114
 115             return $self->$orig( $name, %args );
 116         };
 117 }
 118
 119 {
 120     package Quux;
 121
 122     use Mouse -traits => [ 'My::Trait::AlwaysRO' ];
 123
 124     has 'size' =>
 125         ( is  => 'rw',
 126           isa => 'Int',
 127         );
 128 }
 129
 130 ok( Quux->meta()->has_attribute('size'),
 131     'Quux has size attribute' );
 132 ok( ! Quux->meta()->get_attribute('size')->writer(),
 133     'size attribute does not have a writer' );
 134
 135 {
 136     package My::Class::Whatever;
 137
 138     use Mouse::Role;
 139
 140     sub whatever { 42 }
 141
 142     package Mouse::Meta::Class::Custom::Trait::Whatever;
 143
 144     sub register_implementation {
 145         return 'My::Class::Whatever';
 146     }
 147 }
 148
 149 {
 150     package RanOutOfNames;
 151
 152     use Mouse -traits => [ 'Whatever' ];
 153 }
 154
 155 ok( RanOutOfNames->meta()->meta()->has_method('whatever'),
 156     'RanOutOfNames->meta() has whatever method' );
 157
 158 {
 159     package Role::Foo;
 160
 161     use Mouse::Role -traits => [ 'My::SimpleTrait' ];
 162 }
 163
 164 can_ok( Role::Foo->meta(), 'simple' );
 165 is( Role::Foo->meta()->simple(), 5,
 166     'Role::Foo->meta()->simple() returns expected value' );
 167
 168 {
 169     require Mouse::Util::TypeConstraints;
 170     dies_ok( sub { Mouse::Util::TypeConstraints->import( -traits => 'My::SimpleTrait' ) },
 171              'cannot provide -traits to an exporting module that does not init_meta' );
 172     like( $@, qr/does not have an init_meta/,
 173           '... and error provides a useful explanation' );
 174 }
 175
 176 ### TODO@2009/11/17
 177
 178 {
 179     package Foo::Subclass;
 180
 181     use Mouse -traits => [ 'My::SimpleTrait3' ];
 182
 183     extends 'Foo';
 184 }
 185
 186 can_ok( Foo::Subclass->meta(), 'simple' );
 187 is( Foo::Subclass->meta()->simple(), 5,
 188     'Foo::Subclass->meta()->simple() returns expected value' );
 189 is( Foo::Subclass->meta()->simple2(), 55,
 190     'Foo::Subclass->meta()->simple2() returns expected value' );
 191 can_ok( Foo::Subclass->meta(), 'attr2' );
 192 is( Foo::Subclass->meta()->attr2(), 'something',
 193     'Foo::Subclass->meta()->attr2() returns expected value' );
 194
 195 {
 196
 197     package Class::WithAlreadyPresentTrait;
 198     use Mouse -traits => 'My::SimpleTrait';
 199
 200     has an_attr => ( is => 'ro' );
 201 }
 202
 203 lives_ok {
 204     my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' );
 205     is( $instance->an_attr, 'value', 'Can get value' );
 206 }
 207 'Can create instance and access attributes';
 208
 209 {
 210
 211     package Class::WhichLoadsATraitFromDisk;
 212
 213     # Any role you like here, the only important bit is that it gets
 214     # loaded from disk and has not already been defined.
 215     use Mouse -traits => 'Role::Parent';
 216
 217     has an_attr => ( is => 'ro' );
 218 }
 219
 220 lives_ok {
 221     my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' );
 222     is( $instance->an_attr, 'value', 'Can get value' );
 223 }
 224 'Can create instance and access attributes';