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