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