t/030_roles/003_apply_role.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use Test::More;
   6 BEGIN {
   7     plan skip_all =>
   8             "This test requires Class::Method::Modifiers or Class::Method::Modifiers::Fast"
   9         unless eval {
  10             require Class::Method::Modifiers::Fast;
  11         } or   eval {
  12             require Class::Method::Modifiers;
  13         };
  14 }
  15
  16 plan tests => 86;
  17 use Test::Exception;
  18
  19 {
  20     package FooRole;
  21     use Mouse::Role;
  22
  23     has 'bar' => ( is => 'rw', isa => 'FooClass' );
  24     has 'baz' => ( is => 'ro' );
  25
  26     sub goo {'FooRole::goo'}
  27     sub foo {'FooRole::foo'}
  28
  29     override 'boo' => sub { 'FooRole::boo -> ' . super() };
  30 #    sub boo { 'FooRole::boo -> ' . shift->SUPER::boo() }
  31
  32     around 'blau' => sub {
  33         my $c = shift;
  34         'FooRole::blau -> ' . $c->();
  35     };
  36 }
  37
  38 {
  39     package BarRole;
  40     use Mouse::Role;
  41     sub woot {'BarRole::woot'}
  42 }
  43
  44 {
  45     package BarClass;
  46     use Mouse;
  47
  48     sub boo {'BarClass::boo'}
  49     sub foo {'BarClass::foo'}    # << the role overrides this ...
  50 }
  51
  52 {
  53     package FooClass;
  54     use Mouse;
  55
  56     extends 'BarClass';
  57     with 'FooRole';
  58
  59     sub blau {'FooClass::blau'}    # << the role wraps this ...
  60
  61     sub goo {'FooClass::goo'}      # << overrides the one from the role ...
  62 }
  63
  64 {
  65     package FooBarClass;
  66     use Mouse;
  67
  68     extends 'FooClass';
  69     with 'FooRole', 'BarRole';
  70 }
  71
  72 my $foo_class_meta = FooClass->meta;
  73 isa_ok( $foo_class_meta, 'Mouse::Meta::Class' );
  74
  75 my $foobar_class_meta = FooBarClass->meta;
  76 isa_ok( $foobar_class_meta, 'Mouse::Meta::Class' );
  77
  78 dies_ok {
  79     $foo_class_meta->does_role();
  80 }
  81 '... does_role requires a role name';
  82
  83 dies_ok {
  84     $foo_class_meta->add_role();
  85 }
  86 '... apply_role requires a role';
  87
  88 dies_ok {
  89     $foo_class_meta->add_role( bless( {} => 'Fail' ) );
  90 }
  91 '... apply_role requires a role';
  92
  93 ok( $foo_class_meta->does_role('FooRole'),
  94     '... the FooClass->meta does_role FooRole' );
  95 ok( !$foo_class_meta->does_role('OtherRole'),
  96     '... the FooClass->meta !does_role OtherRole' );
  97
  98 ok( $foobar_class_meta->does_role('FooRole'),
  99     '... the FooBarClass->meta does_role FooRole' );
 100 ok( $foobar_class_meta->does_role('BarRole'),
 101     '... the FooBarClass->meta does_role BarRole' );
 102 ok( !$foobar_class_meta->does_role('OtherRole'),
 103     '... the FooBarClass->meta !does_role OtherRole' );
 104
 105 foreach my $method_name (qw(bar baz foo boo blau goo)) {
 106 #    ok( $foo_class_meta->has_method($method_name), ## Mouse: no ->has_method
 107     ok( FooClass->can($method_name),
 108         '... FooClass has the method ' . $method_name );
 109 #    ok( $foobar_class_meta->has_method($method_name), ## Mouse: no ->has_method
 110     ok( FooClass->can($method_name),
 111         '... FooBarClass has the method ' . $method_name );
 112 }
 113
 114 #ok( !$foo_class_meta->has_method('woot'), ## Mouse: no ->has_method
 115 ok( !FooClass->can('woot'),
 116     '... FooClass lacks the method woot' );
 117 #ok( $foobar_class_meta->has_method('woot'), ## Mouse: no ->has_method
 118 ok( FooBarClass->can('woot'),
 119     '... FooBarClass has the method woot' );
 120
 121 foreach my $attr_name (qw(bar baz)) {
 122     ok( $foo_class_meta->has_attribute($attr_name),
 123         '... FooClass has the attribute ' . $attr_name );
 124     ok( $foobar_class_meta->has_attribute($attr_name),
 125         '... FooBarClass has the attribute ' . $attr_name );
 126 }
 127
 128 can_ok( 'FooClass', 'does' );
 129 ok( FooClass->does('FooRole'),    '... the FooClass does FooRole' );
 130 ok( !FooClass->does('BarRole'),   '... the FooClass does not do BarRole' );
 131 ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' );
 132
 133 can_ok( 'FooBarClass', 'does' );
 134 ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' );
 135 ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' );
 136 ok( !FooBarClass->does('OtherRole'),
 137     '... the FooBarClass does not do OtherRole' );
 138
 139 my $foo = FooClass->new();
 140 isa_ok( $foo, 'FooClass' );
 141
 142 my $foobar = FooBarClass->new();
 143 isa_ok( $foobar, 'FooBarClass' );
 144
 145 is( $foo->goo,    'FooClass::goo', '... got the right value of goo' );
 146 is( $foobar->goo, 'FooRole::goo',  '... got the right value of goo' );
 147
 148 is( $foo->boo, 'FooRole::boo -> BarClass::boo',
 149     '... got the right value from ->boo' );
 150 is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo',
 151     '... got the right value from ->boo (double wrapped)' );
 152
 153 is( $foo->blau, 'FooRole::blau -> FooClass::blau',
 154     '... got the right value from ->blau' );
 155 is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau',
 156     '... got the right value from ->blau' );
 157
 158 foreach my $foo ( $foo, $foobar ) {
 159     can_ok( $foo, 'does' );
 160     ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' );
 161     ok( !$foo->does('OtherRole'),
 162         '... and instance of FooClass does not do OtherRole' );
 163
 164     can_ok( $foobar, 'does' );
 165     ok( $foobar->does('FooRole'),
 166         '... an instance of FooBarClass does FooRole' );
 167     ok( $foobar->does('BarRole'),
 168         '... an instance of FooBarClass does BarRole' );
 169     ok( !$foobar->does('OtherRole'),
 170         '... and instance of FooBarClass does not do OtherRole' );
 171
 172     for my $method (qw/bar baz foo boo goo blau/) {
 173         can_ok( $foo, $method );
 174     }
 175
 176     is( $foo->foo, 'FooRole::foo', '... got the right value of foo' );
 177
 178     ok( !defined( $foo->baz ), '... $foo->baz is undefined' );
 179     ok( !defined( $foo->bar ), '... $foo->bar is undefined' );
 180
 181     dies_ok {
 182         $foo->baz(1);
 183     }
 184     '... baz is a read-only accessor';
 185
 186     dies_ok {
 187         $foo->bar(1);
 188     }
 189     '... bar is a read-write accessor with a type constraint';
 190
 191     my $foo2 = FooClass->new();
 192     isa_ok( $foo2, 'FooClass' );
 193
 194     lives_ok {
 195         $foo->bar($foo2);
 196     }
 197     '... bar is a read-write accessor with a type constraint';
 198
 199     is( $foo->bar, $foo2, '... got the right value for bar now' );
 200 }