t/roles/apply_role.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   8
   9 {
  10     package FooRole;
  11     use Moose::Role;
  12
  13     our $VERSION = 23;
  14
  15     has 'bar' => ( is => 'rw', isa => 'FooClass' );
  16     has 'baz' => ( is => 'ro' );
  17
  18     sub goo {'FooRole::goo'}
  19     sub foo {'FooRole::foo'}
  20
  21     override 'boo' => sub { 'FooRole::boo -> ' . super() };
  22
  23     around 'blau' => sub {
  24         my $c = shift;
  25         'FooRole::blau -> ' . $c->();
  26     };
  27 }
  28
  29 {
  30     package BarRole;
  31     use Moose::Role;
  32     sub woot {'BarRole::woot'}
  33 }
  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
  43 {
  44     package FooClass;
  45     use Moose;
  46
  47     extends 'BarClass';
  48
  49     ::like( ::exception { with 'FooRole' => { -version => 42 } }, qr/FooRole version 42 required--this is only version 23/, 'applying role with unsatisfied version requirement' );
  50
  51     ::is( ::exception { with 'FooRole' => { -version => 13 } }, undef, 'applying role with satisfied version requirement' );
  52
  53     sub blau {'FooClass::blau'}    # << the role wraps this ...
  54
  55     sub goo {'FooClass::goo'}      # << overrides the one from the role ...
  56 }
  57
  58 {
  59     package FooBarClass;
  60     use Moose;
  61
  62     extends 'FooClass';
  63     with 'FooRole', 'BarRole';
  64 }
  65
  66 {
  67     package PlainJane;
  68     sub new { return bless {}, __PACKAGE__; }
  69 }
  70
  71 my $foo_class_meta = FooClass->meta;
  72 isa_ok( $foo_class_meta, 'Moose::Meta::Class' );
  73
  74 my $foobar_class_meta = FooBarClass->meta;
  75 isa_ok( $foobar_class_meta, 'Moose::Meta::Class' );
  76
  77 isnt( exception {
  78     $foo_class_meta->does_role();
  79 }, undef, '... does_role requires a role name' );
  80
  81 isnt( exception {
  82     $foo_class_meta->add_role();
  83 }, undef, '... apply_role requires a role' );
  84
  85 isnt( exception {
  86     $foo_class_meta->add_role( bless( {} => 'Fail' ) );
  87 }, undef, '... apply_role requires a role' );
  88
  89 ok( $foo_class_meta->does_role('FooRole'),
  90     '... the FooClass->meta does_role FooRole' );
  91 ok( !$foo_class_meta->does_role('OtherRole'),
  92     '... the FooClass->meta !does_role OtherRole' );
  93
  94 ok( $foobar_class_meta->does_role('FooRole'),
  95     '... the FooBarClass->meta does_role FooRole' );
  96 ok( $foobar_class_meta->does_role('BarRole'),
  97     '... the FooBarClass->meta does_role BarRole' );
  98 ok( !$foobar_class_meta->does_role('OtherRole'),
  99     '... the FooBarClass->meta !does_role OtherRole' );
 100
 101 foreach my $method_name (qw(bar baz foo boo blau goo)) {
 102     ok( $foo_class_meta->has_method($method_name),
 103         '... FooClass has the method ' . $method_name );
 104     ok( $foobar_class_meta->has_method($method_name),
 105         '... FooBarClass has the method ' . $method_name );
 106 }
 107
 108 ok( !$foo_class_meta->has_method('woot'),
 109     '... FooClass lacks the method woot' );
 110 ok( $foobar_class_meta->has_method('woot'),
 111     '... FooBarClass has the method woot' );
 112
 113 foreach my $attr_name (qw(bar baz)) {
 114     ok( $foo_class_meta->has_attribute($attr_name),
 115         '... FooClass has the attribute ' . $attr_name );
 116     ok( $foobar_class_meta->has_attribute($attr_name),
 117         '... FooBarClass has the attribute ' . $attr_name );
 118 }
 119
 120 can_ok( 'FooClass', 'does' );
 121 ok( FooClass->does('FooRole'),    '... the FooClass does FooRole' );
 122 ok( !FooClass->does('BarRole'),   '... the FooClass does not do BarRole' );
 123 ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' );
 124
 125 can_ok( 'FooBarClass', 'does' );
 126 ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' );
 127 ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' );
 128 ok( !FooBarClass->does('OtherRole'),
 129     '... the FooBarClass does not do OtherRole' );
 130
 131 my $foo = FooClass->new();
 132 isa_ok( $foo, 'FooClass' );
 133
 134 my $foobar = FooBarClass->new();
 135 isa_ok( $foobar, 'FooBarClass' );
 136
 137 is( $foo->goo,    'FooClass::goo', '... got the right value of goo' );
 138 is( $foobar->goo, 'FooRole::goo',  '... got the right value of goo' );
 139
 140 is( $foo->boo, 'FooRole::boo -> BarClass::boo',
 141     '... got the right value from ->boo' );
 142 is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo',
 143     '... got the right value from ->boo (double wrapped)' );
 144
 145 is( $foo->blau, 'FooRole::blau -> FooClass::blau',
 146     '... got the right value from ->blau' );
 147 is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau',
 148     '... got the right value from ->blau' );
 149
 150 foreach my $foo ( $foo, $foobar ) {
 151     can_ok( $foo, 'does' );
 152     ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' );
 153     ok( !$foo->does('OtherRole'),
 154         '... and instance of FooClass does not do OtherRole' );
 155
 156     can_ok( $foobar, 'does' );
 157     ok( $foobar->does('FooRole'),
 158         '... an instance of FooBarClass does FooRole' );
 159     ok( $foobar->does('BarRole'),
 160         '... an instance of FooBarClass does BarRole' );
 161     ok( !$foobar->does('OtherRole'),
 162         '... and instance of FooBarClass does not do OtherRole' );
 163
 164     for my $method (qw/bar baz foo boo goo blau/) {
 165         can_ok( $foo, $method );
 166     }
 167
 168     is( $foo->foo, 'FooRole::foo', '... got the right value of foo' );
 169
 170     ok( !defined( $foo->baz ), '... $foo->baz is undefined' );
 171     ok( !defined( $foo->bar ), '... $foo->bar is undefined' );
 172
 173     isnt( exception {
 174         $foo->baz(1);
 175     }, undef, '... baz is a read-only accessor' );
 176
 177     isnt( exception {
 178         $foo->bar(1);
 179     }, undef, '... bar is a read-write accessor with a type constraint' );
 180
 181     my $foo2 = FooClass->new();
 182     isa_ok( $foo2, 'FooClass' );
 183
 184     is( exception {
 185         $foo->bar($foo2);
 186     }, undef, '... bar is a read-write accessor with a type constraint' );
 187
 188     is( $foo->bar, $foo2, '... got the right value for bar now' );
 189 }
 190
 191 {
 192     {
 193         package MRole;
 194         use Moose::Role;
 195         sub meth { }
 196     }
 197
 198     {
 199         package MRole2;
 200         use Moose::Role;
 201         sub meth2 { }
 202     }
 203
 204     {
 205         use Moose::Meta::Class;
 206         use Moose::Object;
 207         use Moose::Util qw(apply_all_roles);
 208
 209         my $class = Moose::Meta::Class->create( 'Class' => (
 210           superclasses => [ 'Moose::Object' ],
 211         ));
 212
 213         apply_all_roles($class, MRole->meta, MRole2->meta);
 214
 215         ok(Class->can('meth'), "can meth");
 216         ok(Class->can('meth2'), "can meth2");
 217     }
 218 }
 219
 220 {
 221     ok(!Moose::Util::find_meta('PlainJane'), 'not initialized');
 222     Moose::Util::apply_all_roles('PlainJane', 'BarRole');
 223     ok(Moose::Util::find_meta('PlainJane'), 'initialized');
 224     ok(Moose::Util::find_meta('PlainJane')->does_role('BarRole'), 'does BarRole');
 225     my $pj = PlainJane->new();
 226     ok($pj->can('woot'), 'can woot');
 227 }
 228
 229 done_testing;