Commit | Line | Data |
54b1cdf0 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
b10dde3a |
7 | use Test::Fatal; |
54b1cdf0 |
8 | |
f4f3e701 |
9 | =pod |
10 | |
d03bd989 |
11 | This tests the more complex |
12 | delegation cases and that they |
f4f3e701 |
13 | do not fail at compile time. |
14 | |
15 | =cut |
16 | |
54b1cdf0 |
17 | { |
18 | |
19 | package ChildASuper; |
20 | use Moose; |
21 | |
22 | sub child_a_super_method { "as" } |
23 | |
24 | package ChildA; |
25 | use Moose; |
26 | |
27 | extends "ChildASuper"; |
28 | |
29 | sub child_a_method_1 { "a1" } |
30 | sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" } |
31 | |
32 | package ChildASub; |
33 | use Moose; |
34 | |
35 | extends "ChildA"; |
36 | |
37 | sub child_a_method_3 { "a3" } |
38 | |
39 | package ChildB; |
40 | use Moose; |
41 | |
42 | sub child_b_method_1 { "b1" } |
43 | sub child_b_method_2 { "b2" } |
44 | sub child_b_method_3 { "b3" } |
45 | |
46 | package ChildC; |
47 | use Moose; |
48 | |
49 | sub child_c_method_1 { "c1" } |
50 | sub child_c_method_2 { "c2" } |
51 | sub child_c_method_3_la { "c3" } |
52 | sub child_c_method_4_la { "c4" } |
53 | |
54 | package ChildD; |
55 | use Moose; |
56 | |
57 | sub child_d_method_1 { "d1" } |
58 | sub child_d_method_2 { "d2" } |
59 | |
60 | package ChildE; |
61 | # no Moose |
62 | |
63 | sub new { bless {}, shift } |
64 | sub child_e_method_1 { "e1" } |
65 | sub child_e_method_2 { "e2" } |
66 | |
67 | package ChildF; |
68 | # no Moose |
69 | |
70 | sub new { bless {}, shift } |
71 | sub child_f_method_1 { "f1" } |
72 | sub child_f_method_2 { "f2" } |
73 | |
f3c4e20e |
74 | package ChildG; |
75 | use Moose; |
76 | |
77 | sub child_g_method_1 { "g1" } |
78 | |
66559261 |
79 | package ChildH; |
80 | use Moose; |
81 | |
82 | sub child_h_method_1 { "h1" } |
83 | sub parent_method_1 { "child_parent_1" } |
84 | |
85 | package ChildI; |
86 | use Moose; |
87 | |
88 | sub child_i_method_1 { "i1" } |
89 | sub parent_method_1 { "child_parent_1" } |
90 | |
54b1cdf0 |
91 | package Parent; |
92 | use Moose; |
93 | |
575ca974 |
94 | sub parent_method_1 { "parent_1" } |
57a15379 |
95 | ::can_ok('Parent', 'parent_method_1'); |
66559261 |
96 | |
b10dde3a |
97 | ::isnt( ::exception { |
54b1cdf0 |
98 | has child_a => ( |
99 | is => "ro", |
100 | default => sub { ChildA->new }, |
98aae381 |
101 | handles => qr/.*/, |
54b1cdf0 |
102 | ); |
b10dde3a |
103 | }, undef, "all_methods requires explicit isa" ); |
54b1cdf0 |
104 | |
b10dde3a |
105 | ::is( ::exception { |
54b1cdf0 |
106 | has child_a => ( |
107 | isa => "ChildA", |
108 | is => "ro", |
109 | default => sub { ChildA->new }, |
98aae381 |
110 | handles => qr/.*/, |
54b1cdf0 |
111 | ); |
b10dde3a |
112 | }, undef, "allow all_methods with explicit isa" ); |
54b1cdf0 |
113 | |
b10dde3a |
114 | ::is( ::exception { |
54b1cdf0 |
115 | has child_b => ( |
452bac1b |
116 | is => 'ro', |
54b1cdf0 |
117 | default => sub { ChildB->new }, |
118 | handles => [qw/child_b_method_1/], |
119 | ); |
b10dde3a |
120 | }, undef, "don't need to declare isa if method list is predefined" ); |
54b1cdf0 |
121 | |
b10dde3a |
122 | ::is( ::exception { |
54b1cdf0 |
123 | has child_c => ( |
124 | isa => "ChildC", |
125 | is => "ro", |
126 | default => sub { ChildC->new }, |
127 | handles => qr/_la$/, |
128 | ); |
b10dde3a |
129 | }, undef, "can declare regex collector" ); |
54b1cdf0 |
130 | |
b10dde3a |
131 | ::isnt( ::exception { |
54b1cdf0 |
132 | has child_d => ( |
133 | is => "ro", |
134 | default => sub { ChildD->new }, |
135 | handles => sub { |
136 | my ( $class, $delegate_class ) = @_; |
137 | } |
138 | ); |
b10dde3a |
139 | }, undef, "can't create attr with generative handles parameter and no isa" ); |
54b1cdf0 |
140 | |
b10dde3a |
141 | ::is( ::exception { |
54b1cdf0 |
142 | has child_d => ( |
143 | isa => "ChildD", |
144 | is => "ro", |
145 | default => sub { ChildD->new }, |
146 | handles => sub { |
147 | my ( $class, $delegate_class ) = @_; |
148 | return; |
149 | } |
150 | ); |
b10dde3a |
151 | }, undef, "can't create attr with generative handles parameter and no isa" ); |
54b1cdf0 |
152 | |
b10dde3a |
153 | ::is( ::exception { |
54b1cdf0 |
154 | has child_e => ( |
155 | isa => "ChildE", |
156 | is => "ro", |
157 | default => sub { ChildE->new }, |
452bac1b |
158 | handles => ["child_e_method_2"], |
54b1cdf0 |
159 | ); |
b10dde3a |
160 | }, undef, "can delegate to non moose class using explicit method list" ); |
54b1cdf0 |
161 | |
aff2941e |
162 | my $delegate_class; |
b10dde3a |
163 | ::is( ::exception { |
aff2941e |
164 | has child_f => ( |
165 | isa => "ChildF", |
166 | is => "ro", |
167 | default => sub { ChildF->new }, |
168 | handles => sub { |
4e848edb |
169 | $delegate_class = $_[1]->name; |
452bac1b |
170 | return; |
aff2941e |
171 | }, |
172 | ); |
b10dde3a |
173 | }, undef, "subrefs on non moose class give no meta" ); |
aff2941e |
174 | |
175 | ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" ); |
d03bd989 |
176 | |
b10dde3a |
177 | ::is( ::exception { |
f3c4e20e |
178 | has child_g => ( |
179 | isa => "ChildG", |
180 | default => sub { ChildG->new }, |
181 | handles => ["child_g_method_1"], |
182 | ); |
b10dde3a |
183 | }, undef, "can delegate to object even without explicit reader" ); |
54b1cdf0 |
184 | |
57a15379 |
185 | ::can_ok('Parent', 'parent_method_1'); |
b10dde3a |
186 | ::isnt( ::exception { |
66559261 |
187 | has child_h => ( |
188 | isa => "ChildH", |
189 | is => "ro", |
190 | default => sub { ChildH->new }, |
191 | handles => sub { map { $_, $_ } $_[1]->get_all_method_names }, |
192 | ); |
b10dde3a |
193 | }, undef, "Can't override exisiting class method in delegate" ); |
57a15379 |
194 | ::can_ok('Parent', 'parent_method_1'); |
66559261 |
195 | |
b10dde3a |
196 | ::is( ::exception { |
66559261 |
197 | has child_i => ( |
198 | isa => "ChildI", |
199 | is => "ro", |
200 | default => sub { ChildI->new }, |
575ca974 |
201 | handles => sub { |
fe11f190 |
202 | map { $_, $_ } grep { !/^parent_method_1|meta$/ } |
575ca974 |
203 | $_[1]->get_all_method_names; |
204 | }, |
66559261 |
205 | ); |
b10dde3a |
206 | }, undef, "Test handles code ref for skipping predefined methods" ); |
66559261 |
207 | |
208 | |
54b1cdf0 |
209 | sub parent_method { "p" } |
210 | } |
211 | |
212 | # sanity |
213 | |
214 | isa_ok( my $p = Parent->new, "Parent" ); |
215 | isa_ok( $p->child_a, "ChildA" ); |
452bac1b |
216 | isa_ok( $p->child_b, "ChildB" ); |
54b1cdf0 |
217 | isa_ok( $p->child_c, "ChildC" ); |
218 | isa_ok( $p->child_d, "ChildD" ); |
219 | isa_ok( $p->child_e, "ChildE" ); |
aff2941e |
220 | isa_ok( $p->child_f, "ChildF" ); |
66559261 |
221 | isa_ok( $p->child_i, "ChildI" ); |
54b1cdf0 |
222 | |
f3c4e20e |
223 | ok(!$p->can('child_g'), '... no child_g accessor defined'); |
66559261 |
224 | ok(!$p->can('child_h'), '... no child_h accessor defined'); |
f3c4e20e |
225 | |
54b1cdf0 |
226 | |
227 | is( $p->parent_method, "p", "parent method" ); |
228 | is( $p->child_a->child_a_super_method, "as", "child supermethod" ); |
229 | is( $p->child_a->child_a_method_1, "a1", "child method" ); |
230 | |
231 | can_ok( $p, "child_a_super_method" ); |
232 | can_ok( $p, "child_a_method_1" ); |
233 | can_ok( $p, "child_a_method_2" ); |
234 | ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" ); |
235 | |
236 | is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" ); |
237 | is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" ); |
238 | |
239 | |
240 | can_ok( $p, "child_b_method_1" ); |
241 | ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" ); |
242 | |
243 | |
244 | ok( !$p->can($_), "none of ChildD's methods ($_)" ) |
3b82ee4f |
245 | for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods(); |
54b1cdf0 |
246 | |
247 | can_ok( $p, "child_c_method_3_la" ); |
248 | can_ok( $p, "child_c_method_4_la" ); |
249 | |
250 | is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" ); |
251 | |
252 | can_ok( $p, "child_e_method_2" ); |
253 | ok( !$p->can("child_e_method_1"), "but not child_e_method_1"); |
254 | |
255 | is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" ); |
f3c4e20e |
256 | |
257 | can_ok( $p, "child_g_method_1" ); |
258 | is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" ); |
57a15379 |
259 | |
260 | can_ok( $p, "child_i_method_1" ); |
fe11f190 |
261 | is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" ); |
a28e50e4 |
262 | |
263 | done_testing; |