t/020_attributes/017_attribute_traits_n_meta.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use lib 't/lib';
   7
   8 use Test::More tests => 7;
   9 use Test::Exception;
  10 use Test::Mouse;
  11
  12
  13
  14 {
  15     package My::Meta::Attribute::DefaultReadOnly;
  16     use Mouse;
  17
  18     extends 'Mouse::Meta::Attribute';
  19
  20     around 'new' => sub {
  21         my $next = shift;
  22         my ($self, $name, %options) = @_;
  23         $options{is} = 'ro'
  24             unless exists $options{is};
  25         $next->($self, $name, %options);
  26     };
  27 }
  28
  29 {
  30     package My::Attribute::Trait;
  31     use Mouse::Role;
  32
  33     has 'alias_to' => (is => 'ro', isa => 'Str');
  34
  35     after 'install_accessors' => sub {
  36         my $self = shift;
  37         $self->associated_class->add_method(
  38             $self->alias_to,
  39             $self->get_read_method_ref
  40         );
  41     };
  42 }
  43
  44 {
  45     package My::Class;
  46     use Mouse;
  47
  48     has 'bar' => (
  49         metaclass => 'My::Meta::Attribute::DefaultReadOnly',
  50         traits    => [qw/My::Attribute::Trait/],
  51         isa       => 'Int',
  52         alias_to  => 'baz',
  53     );
  54 }
  55
  56 my $c = My::Class->new(bar => 100);
  57 isa_ok($c, 'My::Class');
  58
  59 is($c->bar, 100, '... got the right value for bar');
  60
  61 can_ok($c, 'baz');
  62 is($c->baz, 100, '... got the right value for baz');
  63
  64 isa_ok($c->meta->get_attribute('bar'), 'My::Meta::Attribute::DefaultReadOnly');
  65 does_ok($c->meta->get_attribute('bar'), 'My::Attribute::Trait');
  66 is($c->meta->get_attribute('bar')->_is_metadata, 'ro', '... got the right metaclass customization');
  67
  68
  69
  70