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