t/050_metaclasses/013_metaclass_traits.t

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