t/030_roles/003_apply_role.t

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