t-failing/030_roles/003_apply_role.t

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