t/030_roles/003_apply_role.t

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