t/030_roles/003_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 my $foo_class_meta = FooClass->meta;
  67 isa_ok( $foo_class_meta, 'Moose::Meta::Class' );
  68
  69 my $foobar_class_meta = FooBarClass->meta;
  70 isa_ok( $foobar_class_meta, 'Moose::Meta::Class' );
  71
  72 isnt( exception {
  73     $foo_class_meta->does_role();
  74 }, undef, '... does_role requires a role name' );
  75
  76 isnt( exception {
  77     $foo_class_meta->add_role();
  78 }, undef, '... apply_role requires a role' );
  79
  80 isnt( exception {
  81     $foo_class_meta->add_role( bless( {} => 'Fail' ) );
  82 }, undef, '... apply_role requires a role' );
  83
  84 ok( $foo_class_meta->does_role('FooRole'),
  85     '... the FooClass->meta does_role FooRole' );
  86 ok( !$foo_class_meta->does_role('OtherRole'),
  87     '... the FooClass->meta !does_role OtherRole' );
  88
  89 ok( $foobar_class_meta->does_role('FooRole'),
  90     '... the FooBarClass->meta does_role FooRole' );
  91 ok( $foobar_class_meta->does_role('BarRole'),
  92     '... the FooBarClass->meta does_role BarRole' );
  93 ok( !$foobar_class_meta->does_role('OtherRole'),
  94     '... the FooBarClass->meta !does_role OtherRole' );
  95
  96 foreach my $method_name (qw(bar baz foo boo blau goo)) {
  97     ok( $foo_class_meta->has_method($method_name),
  98         '... FooClass has the method ' . $method_name );
  99     ok( $foobar_class_meta->has_method($method_name),
 100         '... FooBarClass has the method ' . $method_name );
 101 }
 102
 103 ok( !$foo_class_meta->has_method('woot'),
 104     '... FooClass lacks the method woot' );
 105 ok( $foobar_class_meta->has_method('woot'),
 106     '... FooBarClass has the method woot' );
 107
 108 foreach my $attr_name (qw(bar baz)) {
 109     ok( $foo_class_meta->has_attribute($attr_name),
 110         '... FooClass has the attribute ' . $attr_name );
 111     ok( $foobar_class_meta->has_attribute($attr_name),
 112         '... FooBarClass has the attribute ' . $attr_name );
 113 }
 114
 115 can_ok( 'FooClass', 'does' );
 116 ok( FooClass->does('FooRole'),    '... the FooClass does FooRole' );
 117 ok( !FooClass->does('BarRole'),   '... the FooClass does not do BarRole' );
 118 ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' );
 119
 120 can_ok( 'FooBarClass', 'does' );
 121 ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' );
 122 ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' );
 123 ok( !FooBarClass->does('OtherRole'),
 124     '... the FooBarClass does not do OtherRole' );
 125
 126 my $foo = FooClass->new();
 127 isa_ok( $foo, 'FooClass' );
 128
 129 my $foobar = FooBarClass->new();
 130 isa_ok( $foobar, 'FooBarClass' );
 131
 132 is( $foo->goo,    'FooClass::goo', '... got the right value of goo' );
 133 is( $foobar->goo, 'FooRole::goo',  '... got the right value of goo' );
 134
 135 is( $foo->boo, 'FooRole::boo -> BarClass::boo',
 136     '... got the right value from ->boo' );
 137 is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo',
 138     '... got the right value from ->boo (double wrapped)' );
 139
 140 is( $foo->blau, 'FooRole::blau -> FooClass::blau',
 141     '... got the right value from ->blau' );
 142 is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau',
 143     '... got the right value from ->blau' );
 144
 145 foreach my $foo ( $foo, $foobar ) {
 146     can_ok( $foo, 'does' );
 147     ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' );
 148     ok( !$foo->does('OtherRole'),
 149         '... and instance of FooClass does not do OtherRole' );
 150
 151     can_ok( $foobar, 'does' );
 152     ok( $foobar->does('FooRole'),
 153         '... an instance of FooBarClass does FooRole' );
 154     ok( $foobar->does('BarRole'),
 155         '... an instance of FooBarClass does BarRole' );
 156     ok( !$foobar->does('OtherRole'),
 157         '... and instance of FooBarClass does not do OtherRole' );
 158
 159     for my $method (qw/bar baz foo boo goo blau/) {
 160         can_ok( $foo, $method );
 161     }
 162
 163     is( $foo->foo, 'FooRole::foo', '... got the right value of foo' );
 164
 165     ok( !defined( $foo->baz ), '... $foo->baz is undefined' );
 166     ok( !defined( $foo->bar ), '... $foo->bar is undefined' );
 167
 168     isnt( exception {
 169         $foo->baz(1);
 170     }, undef, '... baz is a read-only accessor' );
 171
 172     isnt( exception {
 173         $foo->bar(1);
 174     }, undef, '... bar is a read-write accessor with a type constraint' );
 175
 176     my $foo2 = FooClass->new();
 177     isa_ok( $foo2, 'FooClass' );
 178
 179     is( exception {
 180         $foo->bar($foo2);
 181     }, undef, '... bar is a read-write accessor with a type constraint' );
 182
 183     is( $foo->bar, $foo2, '... got the right value for bar now' );
 184 }
 185
 186 done_testing;