t/030_roles/003_apply_role.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 87;
   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 }{
  31     package BarRole;
  32     use Moose::Role;
  33     sub woot { 'BarRole::woot' }
  34
  35 }{
  36     package BarClass;
  37     use Moose;
  38
  39     sub boo { 'BarClass::boo' }
  40     sub foo { 'BarClass::foo' }  # << the role overrides this ...
  41
  42     metaclass->make_immutable(debug => 0);
  43 }{
  44
  45     package FooClass;
  46     use Moose;
  47
  48     extends 'BarClass';
  49        with 'FooRole';
  50
  51     sub blau { 'FooClass::blau' } # << the role wraps this ...
  52
  53     sub goo { 'FooClass::goo' }  # << overrides the one from the role ...
  54
  55     metaclass->make_immutable(debug => 0);
  56 }{
  57
  58     package FooBarClass;
  59     use Moose;
  60
  61     extends 'FooClass';
  62        with 'FooRole', 'BarRole';
  63 }
  64
  65 my $foo_class_meta = FooClass->meta;
  66 isa_ok($foo_class_meta, 'Moose::Meta::Class');
  67
  68 my $foobar_class_meta = FooBarClass->meta;
  69 isa_ok($foobar_class_meta, 'Moose::Meta::Class');
  70
  71 dies_ok {
  72     $foo_class_meta->does_role()
  73 } '... does_role requires a role name';
  74
  75 dies_ok {
  76     $foo_class_meta->apply_role()
  77 } '... apply_role requires a role';
  78
  79 dies_ok {
  80     $foo_class_meta->apply_role(bless({} => 'Fail'))
  81 } '... apply_role requires a role';
  82
  83 ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole');
  84 ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole');
  85
  86 ok($foobar_class_meta->does_role('FooRole'), '... the FooBarClass->meta does_role FooRole');
  87 ok($foobar_class_meta->does_role('BarRole'), '... the FooBarClass->meta does_role BarRole');
  88 ok(!$foobar_class_meta->does_role('OtherRole'), '... the FooBarClass->meta !does_role OtherRole');
  89
  90 foreach my $method_name (qw(bar baz foo boo blau goo)) {
  91     ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name);
  92     ok($foobar_class_meta->has_method($method_name), '... FooBarClass has the method ' . $method_name);
  93 }
  94
  95 ok(!$foo_class_meta->has_method('woot'), '... FooClass lacks the method woot');
  96 ok($foobar_class_meta->has_method('woot'), '... FooBarClass has the method woot');
  97
  98 foreach my $attr_name (qw(bar baz)) {
  99     ok($foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name);
 100     ok($foobar_class_meta->has_attribute($attr_name), '... FooBarClass has the attribute ' . $attr_name);
 101 }
 102
 103 can_ok('FooClass', 'does');
 104 ok(FooClass->does('FooRole'), '... the FooClass does FooRole');
 105 ok(!FooClass->does('BarRole'), '... the FooClass does not do BarRole');
 106 ok(!FooClass->does('OtherRole'), '... the FooClass does not do OtherRole');
 107
 108 can_ok('FooBarClass', 'does');
 109 ok(FooBarClass->does('FooRole'), '... the FooClass does FooRole');
 110 ok(FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole');
 111 ok(!FooBarClass->does('OtherRole'), '... the FooBarClass does not do OtherRole');
 112
 113 my $foo = FooClass->new();
 114 isa_ok($foo, 'FooClass');
 115
 116 my $foobar = FooBarClass->new();
 117 isa_ok($foobar, 'FooBarClass');
 118
 119 is($foo->goo, 'FooClass::goo', '... got the right value of goo');
 120 is($foobar->goo, 'FooRole::goo', '... got the right value of goo');
 121
 122 is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo');
 123 is($foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', '... got the right value from ->boo (double wrapped)');
 124
 125 is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau');
 126 is($foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', '... got the right value from ->blau');
 127
 128 foreach my $foo ($foo, $foobar) {
 129     can_ok($foo, 'does');
 130     ok($foo->does('FooRole'), '... an instance of FooClass does FooRole');
 131     ok(!$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole');
 132
 133     can_ok($foobar, 'does');
 134     ok($foobar->does('FooRole'), '... an instance of FooBarClass does FooRole');
 135     ok($foobar->does('BarRole'), '... an instance of FooBarClass does BarRole');
 136     ok(!$foobar->does('OtherRole'), '... and instance of FooBarClass does not do OtherRole');
 137
 138     for my $method (qw/bar baz foo boo goo blau/) {
 139         can_ok($foo, $method);
 140     }
 141
 142     is($foo->foo, 'FooRole::foo', '... got the right value of foo');
 143
 144     ok(!defined($foo->baz), '... $foo->baz is undefined');
 145     ok(!defined($foo->bar), '... $foo->bar is undefined');
 146
 147     dies_ok {
 148         $foo->baz(1)
 149     } '... baz is a read-only accessor';
 150
 151     dies_ok {
 152         $foo->bar(1)
 153     } '... bar is a read-write accessor with a type constraint';
 154
 155     my $foo2 = FooClass->new();
 156     isa_ok($foo2, 'FooClass');
 157
 158     lives_ok {
 159         $foo->bar($foo2)
 160     } '... bar is a read-write accessor with a type constraint';
 161
 162     is($foo->bar, $foo2, '... got the right value for bar now');
 163 }