1use strict; 2use warnings; 3use Test::More; 4 5my $backcompat_called; 6{ 7 package RoleExtension; 8 use base 'Role::Tiny'; 9 10 sub apply_single_role_to_package { 11 my $me = shift; 12 $me->SUPER::apply_single_role_to_package(@_); 13 $backcompat_called++; 14 } 15} 16{ 17 package RoleExtension2; 18 use base 'Role::Tiny'; 19 20 sub role_application_steps { 21 $_[0]->SUPER::role_application_steps; 22 } 23 24 sub apply_single_role_to_package { 25 my $me = shift; 26 $me->SUPER::apply_single_role_to_package(@_); 27 $backcompat_called++; 28 } 29 30} 31 32{ 33 package Role1; 34 $INC{'Role1.pm'} = __FILE__; 35 use Role::Tiny; 36 sub sub1 {} 37} 38 39{ 40 package Role2; 41 $INC{'Role2.pm'} = __FILE__; 42 use Role::Tiny; 43 sub sub2 {} 44} 45 46{ 47 package Class1; 48 RoleExtension->apply_roles_to_package(__PACKAGE__, 'Role1', 'Role2'); 49} 50 51is $backcompat_called, 2, 52 'overridden apply_single_role_to_package called for backcompat'; 53 54$backcompat_called = 0; 55{ 56 package Class2; 57 RoleExtension2->apply_roles_to_package(__PACKAGE__, 'Role1', 'Role2'); 58} 59is $backcompat_called, 0, 60 'overridden role_application_steps prevents backcompat attempt'; 61 62{ 63 package ClassWithoutExtraMethod; 64 sub foo {} 65} 66{ 67 package RoleWithRequires; 68 use Role::Tiny; 69 requires 'extra_sub'; 70} 71eval { Role::Tiny->create_class_with_roles('ClassWithoutExtraMethod', 'RoleWithRequires') }; 72like $@, qr/extra_sub/, 73 'requires checked properly during create_class_with_roles'; 74 75 76SKIP: { 77 skip "Class::Method::Modifiers not installed or too old", 1 78 unless eval "use Class::Method::Modifiers 1.05; 1"; 79 { 80 package RoleWithAround; 81 use Role::Tiny; 82 around extra_sub => sub { my $orig = shift; $orig->(@_); }; 83 } 84 85 eval { Role::Tiny->create_class_with_roles('ClassWithoutExtraMethod', 'RoleWithAround') }; 86 like $@, qr/extra_sub/, 87 'requires for modifiers checked properly during create_class_with_roles'; 88} 89 90{ 91 package SimpleRole1; 92 use Role::Tiny; 93 sub role_method { __PACKAGE__ } 94} 95 96{ 97 package SimpleRole2; 98 use Role::Tiny; 99 sub role_method { __PACKAGE__ } 100} 101 102{ 103 package SomeEmptyClass; 104 $INC{'SomeEmptyClass.pm'} ||= __FILE__; 105} 106 107{ 108 my $create_class = Role::Tiny->create_class_with_roles('SomeEmptyClass', 'SimpleRole1'); 109 Role::Tiny->apply_roles_to_package( $create_class, 'SimpleRole2' ); 110 111 my $manual_extend = 'ManualExtend'; 112 @ManualExtend::ISA = qw(SomeEmptyClass); 113 Role::Tiny->apply_roles_to_package( $manual_extend, 'SimpleRole1' ); 114 Role::Tiny->apply_roles_to_package( $manual_extend, 'SimpleRole2' ); 115 116 is $create_class->role_method, $manual_extend->role_method, 117 'methods added by create_class_with_roles treated equal to those added with apply_roles_to_package'; 118} 119 120SKIP: { 121 skip "Class::Method::Modifiers not installed or too old", 1 122 unless eval "use Class::Method::Modifiers 1.05; 1"; 123 { 124 package CreateMITest::Top; 125 sub method { return __PACKAGE__ } 126 127 package CreateMITest::Left; 128 our @ISA = qw(CreateMITest::Top); 129 130 package CreateMITest::Right; 131 our @ISA = qw(CreateMITest::Top); 132 sub method { return (__PACKAGE__, $_[0]->SUPER::method); } 133 134 package CreateMITest::Bottom; 135 our @ISA = qw(CreateMITest::Left CreateMITest::Right); 136 } 137 138 { 139 package CreateMITest::MyRole; 140 use Role::Tiny; 141 around method => sub { 142 my ($orig, $self) = (shift, shift); 143 return (__PACKAGE__, $self->$orig); 144 }; 145 } 146 147 { 148 package CreateMITest::MyChild; 149 use Role::Tiny::With; 150 our @ISA = qw(CreateMITest::Bottom); 151 with 'CreateMITest::MyRole'; 152 } 153 154 my $child_with = 'CreateMITest::MyChild'; 155 my $child_gen = Role::Tiny->create_class_with_roles('CreateMITest::Bottom', 'CreateMITest::MyRole'); 156 157 my @want = $child_with->method; 158 my @got = $child_gen->method; 159 160 is join(', ', @got), join(', ', @want), 161 'create_class_with_roles follows same MRO as equivalent using with'; 162} 163 164done_testing; 165