t/042_apply_role.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 28;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     use_ok('Moose::Role');
  11 }
  12
  13 {
  14     package FooRole;
  15     use strict;
  16     use warnings;
  17     use Moose::Role;
  18
  19     has 'bar' => (is => 'rw', isa => 'FooClass');
  20     has 'baz' => (is => 'ro');
  21
  22     sub goo { 'FooRole::goo' }
  23     sub foo { 'FooRole::foo' }
  24
  25     override 'boo' => sub { 'FooRole::boo -> ' . super() };
  26
  27     around 'blau' => sub {
  28         my $c = shift;
  29         'FooRole::blau -> ' . $c->();
  30     };
  31
  32     package BarClass;
  33     use strict;
  34     use warnings;
  35     use Moose;
  36
  37     sub boo { 'BarClass::boo' }
  38     sub foo { 'BarClass::foo' }  # << the role overrides this ...
  39
  40     package FooClass;
  41     use strict;
  42     use warnings;
  43     use Moose;
  44
  45     extends 'BarClass';
  46        with 'FooRole';
  47
  48     sub blau { 'FooClass::blau' }
  49
  50     sub goo { 'FooClass::goo' }  # << overrides the one from the role ...
  51 }
  52
  53 my $foo_class_meta = FooClass->meta;
  54 isa_ok($foo_class_meta, 'Moose::Meta::Class');
  55
  56 foreach my $method_name (qw(bar baz foo boo blau goo)) {
  57     ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name);
  58 }
  59
  60 foreach my $attr_name (qw(bar baz)) {
  61     ok($foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name);
  62 }
  63
  64 my $foo = FooClass->new();
  65 isa_ok($foo, 'FooClass');
  66
  67 can_ok($foo, 'bar');
  68 can_ok($foo, 'baz');
  69 can_ok($foo, 'foo');
  70 can_ok($foo, 'boo');
  71 can_ok($foo, 'goo');
  72 can_ok($foo, 'blau');
  73
  74 is($foo->foo, 'FooRole::foo', '... got the right value of foo');
  75 is($foo->goo, 'FooClass::goo', '... got the right value of goo');
  76
  77 ok(!defined($foo->baz), '... $foo->baz is undefined');
  78 ok(!defined($foo->bar), '... $foo->bar is undefined');
  79
  80 dies_ok {
  81     $foo->baz(1)
  82 } '... baz is a read-only accessor';
  83
  84 dies_ok {
  85     $foo->bar(1)
  86 } '... bar is a read-write accessor with a type constraint';
  87
  88 my $foo2 = FooClass->new();
  89 isa_ok($foo2, 'FooClass');
  90
  91 lives_ok {
  92     $foo->bar($foo2)
  93 } '... bar is a read-write accessor with a type constraint';
  94
  95 is($foo->bar, $foo2, '... got the right value for bar now');
  96
  97 is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo');
  98 is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau');
  99