t/042_apply_role.t

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