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