t/role-basic-composition.t

   1 use lib 'lib', 't/role-basic/lib';
   2 use MyTests;
   3 require Role::Tiny;
   4
   5 {
   6
   7     package My::Does::Basic1;
   8     use Role::Tiny;
   9     requires 'turbo_charger';
  10
  11     sub method {
  12         return __PACKAGE__ . " method";
  13     }
  14 }
  15 {
  16
  17     package My::Does::Basic2;
  18     use Role::Tiny;
  19     requires 'turbo_charger';
  20
  21     sub method2 {
  22         return __PACKAGE__ . " method2";
  23     }
  24 }
  25
  26 eval <<'END_PACKAGE';
  27 package My::Class1;
  28 use Role::Tiny 'with';
  29 with qw(
  30     My::Does::Basic1
  31     My::Does::Basic2
  32 );
  33 sub turbo_charger {}
  34 END_PACKAGE
  35 ok !$@, 'We should be able to use two roles with the same requirements'
  36     or die $@;
  37
  38 {
  39
  40     package My::Does::Basic3;
  41     use Role::Tiny;
  42     with 'My::Does::Basic2';
  43
  44     sub method3 {
  45         return __PACKAGE__ . " method3";
  46     }
  47 }
  48
  49 eval <<'END_PACKAGE';
  50 package My::Class2;
  51 use Role::Tiny 'with';
  52 with qw(
  53     My::Does::Basic3
  54 );
  55 sub new { bless {} => shift }
  56 sub turbo_charger {}
  57 END_PACKAGE
  58 ok !$@, 'We should be able to use roles which consume roles'
  59     or die $@;
  60 can_ok 'My::Class2', 'method2';
  61 is My::Class2->method2, 'My::Does::Basic2 method2',
  62   '... and it should be the correct method';
  63 can_ok 'My::Class2', 'method3';
  64 is My::Class2->method3, 'My::Does::Basic3 method3',
  65   '... and it should be the correct method';
  66
  67 ok My::Class2->Role::Tiny::does_role('My::Does::Basic3'), 'A class DOES roles which it consumes';
  68 ok My::Class2->Role::Tiny::does_role('My::Does::Basic2'),
  69   '... and should do roles which its roles consumes';
  70 ok !My::Class2->Role::Tiny::does_role('My::Does::Basic1'),
  71   '... but not roles which it never consumed';
  72
  73 my $object = My::Class2->new;
  74 ok $object->Role::Tiny::does_role('My::Does::Basic3'), 'An instance DOES roles which its class consumes';
  75 ok $object->Role::Tiny::does_role('My::Does::Basic2'),
  76   '... and should do roles which its roles consumes';
  77 ok !$object->Role::Tiny::does_role('My::Does::Basic1'),
  78   '... but not roles which it never consumed';
  79
  80 {
  81     {
  82         package Role::Which::Imports;
  83         use Role::Tiny allow => 'TestMethods';
  84         use TestMethods qw(this that);
  85     }
  86     {
  87        package Class::With::ImportingRole;
  88        use Role::Tiny 'with';
  89        with 'Role::Which::Imports';
  90        sub new { bless {} => shift }
  91     }
  92     my $o = Class::With::ImportingRole->new;
  93
  94     foreach my $method (qw/this that/) {
  95         can_ok $o, $method;
  96         ok $o->$method($method), '... and calling "allow"ed methods should succeed';
  97         is $o->$method, $method, '... and it should function correctly';
  98     }
  99 }
 100
 101 {
 102     {
 103         package Role::WithImportsOnceRemoved;
 104         use Role::Tiny;
 105         with 'Role::Which::Imports';
 106     }
 107     {
 108         package Class::With::ImportingRole2;
 109         use Role::Tiny 'with';
 110 $ENV{DEBUG} = 1;
 111         with 'Role::WithImportsOnceRemoved';
 112         sub new { bless {} => shift }
 113     }
 114     ok my $o = Class::With::ImportingRole2->new,
 115         'We should be able to use roles which compose roles which import';
 116
 117     foreach my $method (qw/this that/) {
 118         can_ok $o, $method;
 119         ok $o->$method($method), '... and calling "allow"ed methods should succeed';
 120         is $o->$method, $method, '... and it should function correctly';
 121     }
 122 }
 123
 124 {
 125         {
 126                 package Method::Role1;
 127                 use Role::Tiny;
 128                 sub method1 { }
 129                 requires 'method2';
 130         }
 131
 132         {
 133                 package Method::Role2;
 134                 use Role::Tiny;
 135                 sub method2 { }
 136                 requires 'method1';
 137         }
 138         my $success = eval q{
 139                 package Class;
 140                 use Role::Tiny::With;
 141                 with 'Method::Role1', 'Method::Role2';
 142                 1;
 143         };
 144         is $success, 1, 'composed mutually dependent methods successfully' or diag "Error: $@";
 145 }
 146
 147 SKIP: {
 148   skip "Class::Method::Modifiers not installed or too old", 1
 149     unless eval "use Class::Method::Modifiers 1.05; 1";
 150         {
 151                 package Modifier::Role1;
 152                 use Role::Tiny;
 153                 sub foo {
 154                 }
 155                 before 'bar', sub {};
 156         }
 157
 158         {
 159                 package Modifier::Role2;
 160                 use Role::Tiny;
 161                 sub bar {
 162                 }
 163                 before 'foo', sub {};
 164         }
 165         my $success = eval q{
 166                 package Class;
 167                 use Role::Tiny::With;
 168                 with 'Modifier::Role1', 'Modifier::Role2';
 169                 1;
 170         };
 171         is $success, 1, 'composed mutually dependent modifiers successfully' or diag "Error: $@";
 172 }
 173
 174 {
 175         {
 176                 package Base::Role;
 177                 use Role::Tiny;
 178                 requires qw/method1 method2/;
 179         }
 180
 181         {
 182                 package Sub::Role1;
 183                 use Role::Tiny;
 184                 with 'Base::Role';
 185                 sub method1 {}
 186         }
 187
 188         {
 189                 package Sub::Role2;
 190                 use Role::Tiny;
 191                 with 'Base::Role';
 192                 sub method2 {}
 193         }
 194
 195         my $success = eval q{
 196                 package Diamant::Class;
 197                 use Role::Tiny::With;
 198                 with qw/Sub::Role1 Sub::Role2/;
 199                 1;
 200         };
 201         is $success, 1, 'composed diamantly dependent roles successfully' or diag "Error: $@";
 202 }
 203
 204 {
 205     {
 206         package My::Does::Conflict;
 207         use Role::Tiny;
 208
 209         sub method {
 210             return __PACKAGE__ . " method";
 211         }
 212     }
 213     {
 214         package My::Class::Base;
 215
 216         sub turbo_charger {
 217             return __PACKAGE__ . " turbo charger";
 218         }
 219         sub method {
 220             return __PACKAGE__ . " method";
 221         }
 222     }
 223     my $success = eval q{
 224         package My::Class::Child;
 225         use base 'My::Class::Base';
 226         use Role::Tiny::With;
 227         with qw/My::Does::Basic1 My::Does::Conflict/;
 228         1;
 229     };
 230     is $success, 1, 'role conflict resolved by superclass method' or diag "Error: $@";
 231     can_ok 'My::Class::Child', 'method';
 232     is My::Class::Child->method, 'My::Class::Base method', 'inherited method prevails';
 233 }
 234
 235 done_testing;