t/030_roles/009_more_role_edge_cases.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 74;
   7 use Test::Exception;
   8
   9
  10
  11 {
  12     # NOTE:
  13     # this tests that repeated role
  14     # composition will not cause
  15     # a conflict between two methods
  16     # which are actually the same anyway
  17
  18     {
  19         package RootA;
  20         use Mouse::Role;
  21
  22         sub foo { "RootA::foo" }
  23
  24         package SubAA;
  25         use Mouse::Role;
  26
  27         with "RootA";
  28
  29         sub bar { "SubAA::bar" }
  30
  31         package SubAB;
  32         use Mouse;
  33
  34         ::lives_ok {
  35             with "SubAA", "RootA";
  36         } '... role was composed as expected';
  37     }
  38
  39     ok( SubAB->does("SubAA"), "does SubAA");
  40     ok( SubAB->does("RootA"), "does RootA");
  41
  42     isa_ok( my $i = SubAB->new, "SubAB" );
  43
  44     can_ok( $i, "bar" );
  45     is( $i->bar, "SubAA::bar", "... got thr right bar rv" );
  46
  47     can_ok( $i, "foo" );
  48     my $foo_rv;
  49     lives_ok {
  50         $foo_rv = $i->foo;
  51     } '... called foo successfully';
  52     is($foo_rv, "RootA::foo", "... got the right foo rv");
  53 }
  54
  55 {
  56     # NOTE:
  57     # this edge cases shows the application of
  58     # an after modifier over a method which
  59     # was added during role composotion.
  60     # The way this will work is as follows:
  61     #    role SubBA will consume RootB and
  62     #    get a local copy of RootB::foo, it
  63     #    will also store a deferred after modifier
  64     #    to be applied to whatever class SubBA is
  65     #    composed into.
  66     #    When class SubBB comsumed role SubBA, the
  67     #    RootB::foo method is added to SubBB, then
  68     #    the deferred after modifier from SubBA is
  69     #    applied to it.
  70     # It is important to note that the application
  71     # of the after modifier does not happen until
  72     # role SubBA is composed into SubAA.
  73
  74     {
  75         package RootB;
  76         use Mouse::Role;
  77
  78         sub foo { "RootB::foo" }
  79
  80         package SubBA;
  81         use Mouse::Role;
  82
  83         with "RootB";
  84
  85         has counter => (
  86             isa => "Num",
  87             is  => "rw",
  88             default => 0,
  89         );
  90
  91         after foo => sub {
  92             $_[0]->counter( $_[0]->counter + 1 );
  93         };
  94
  95         package SubBB;
  96         use Mouse;
  97
  98         ::lives_ok {
  99             with "SubBA";
 100         } '... composed the role successfully';
 101     }
 102
 103     ok( SubBB->does("SubBA"), "BB does SubBA" );
 104     ok( SubBB->does("RootB"), "BB does RootB" );
 105
 106     isa_ok( my $i = SubBB->new, "SubBB" );
 107
 108     can_ok( $i, "foo" );
 109
 110     my $foo_rv;
 111     lives_ok {
 112         $foo_rv = $i->foo
 113     } '... called foo successfully';
 114     is( $foo_rv, "RootB::foo", "foo rv" );
 115     is( $i->counter, 1, "after hook called" );
 116
 117     lives_ok { $i->foo } '... called foo successfully (again)';
 118     is( $i->counter, 2, "after hook called (again)" );
 119
 120     ok(SubBA->meta->has_method('foo'), '... this has the foo method');
 121     #my $subba_foo_rv;
 122     #lives_ok {
 123     #    $subba_foo_rv = SubBA::foo();
 124     #} '... called the sub as a function correctly';
 125     #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version');
 126 }
 127
 128 {
 129     # NOTE:
 130     # this checks that an override method
 131     # does not try to trample over a locally
 132     # composed in method. In this case the
 133     # RootC::foo, which is composed into
 134     # SubCA cannot be trampled with an
 135     # override of 'foo'
 136     {
 137         package RootC;
 138         use Mouse::Role;
 139
 140         sub foo { "RootC::foo" }
 141
 142         package SubCA;
 143         use Mouse::Role;
 144
 145         with "RootC";
 146
 147         ::dies_ok {
 148             override foo => sub { "overridden" };
 149         } '... cannot compose an override over a local method';
 150     }
 151 }
 152
 153 # NOTE:
 154 # need to talk to Yuval about the motivation behind
 155 # this test, I am not sure we are testing anything
 156 # useful here (although more tests cant hurt)
 157
 158 {
 159     use List::Util qw/shuffle/;
 160
 161     {
 162         package Abstract;
 163         use Mouse::Role;
 164
 165         requires "method";
 166         requires "other";
 167
 168         sub another { "abstract" }
 169
 170         package ConcreteA;
 171         use Mouse::Role;
 172         with "Abstract";
 173
 174         sub other { "concrete a" }
 175
 176         package ConcreteB;
 177         use Mouse::Role;
 178         with "Abstract";
 179
 180         sub method { "concrete b" }
 181
 182         package ConcreteC;
 183         use Mouse::Role;
 184         with "ConcreteA";
 185
 186         # NOTE:
 187         # this was originally override, but
 188         # that wont work (see above set of tests)
 189         # so I switched it to around.
 190         # However, this may not be testing the
 191         # same thing that was originally intended
 192         around other => sub {
 193             return ( (shift)->() . " + c" );
 194         };
 195
 196         package SimpleClassWithSome;
 197         use Mouse;
 198
 199         eval { with ::shuffle qw/ConcreteA ConcreteB/ };
 200         ::ok( !$@, "simple composition without abstract" ) || ::diag $@;
 201
 202         package SimpleClassWithAll;
 203         use Mouse;
 204
 205         eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ };
 206         ::ok( !$@, "simple composition with abstract" ) || ::diag $@;
 207     }
 208
 209     foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) {
 210         foreach my $role (qw/Abstract ConcreteA ConcreteB/) {
 211             ok( $class->does($role), "$class does $role");
 212         }
 213
 214         foreach my $method (qw/method other another/) {
 215             can_ok( $class, $method );
 216         }
 217
 218         is( eval { $class->another }, "abstract", "provided by abstract" );
 219         is( eval { $class->other }, "concrete a", "provided by concrete a" );
 220         is( eval { $class->method }, "concrete b", "provided by concrete b" );
 221     }
 222
 223     {
 224         package ClassWithSome;
 225         use Mouse;
 226
 227         eval { with ::shuffle qw/ConcreteC ConcreteB/ };
 228         ::ok( !$@, "composition without abstract" ) || ::diag $@;
 229
 230         package ClassWithAll;
 231         use Mouse;
 232
 233         eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ };
 234         ::ok( !$@, "composition with abstract" ) || ::diag $@;
 235
 236         package ClassWithEverything;
 237         use Mouse;
 238
 239         eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash
 240         ::ok( !$@, "can compose ConcreteA and ConcreteC together" );
 241     }
 242
 243     foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) {
 244         foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) {
 245             ok( $class->does($role), "$class does $role");
 246         }
 247
 248         foreach my $method (qw/method other another/) {
 249             can_ok( $class, $method );
 250         }
 251
 252         is( eval { $class->another }, "abstract", "provided by abstract" );
 253         is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" );
 254         is( eval { $class->method }, "concrete b", "provided by concrete b" );
 255     }
 256 }