Commit | Line | Data |
879a325b |
1 | #!perl -T |
2 | use strict; |
3 | use warnings; |
c13900f1 |
4 | |
43e6a50b |
5 | use Test::More tests => 25; |
879a325b |
6 | |
7 | my @seen; |
8 | my @expected = ("before 4", |
9 | "before 3", |
10 | "around 4 before", |
11 | "around 3 before", |
12 | "before 2", |
13 | "before 1", |
14 | "around 2 before", |
15 | "around 1 before", |
16 | "orig", |
17 | "around 1 after", |
18 | "around 2 after", |
19 | "after 1", |
20 | "after 2", |
21 | "around 3 after", |
22 | "around 4 after", |
23 | "after 3", |
24 | "after 4", |
25 | ); |
26 | |
27 | my $child = Grandchild->new; $child->orig; |
28 | |
29 | is_deeply(\@seen, \@expected, "multiple afters called in the right order"); |
30 | |
31 | BEGIN { |
32 | package Parent; |
33 | use Mouse; |
34 | |
35 | sub orig { |
36 | push @seen, "orig"; |
37 | } |
38 | } |
39 | |
40 | BEGIN { |
41 | package Child; |
42 | use Mouse; |
43 | extends 'Parent'; |
44 | |
45 | before orig => sub { |
46 | push @seen, "before 1"; |
47 | }; |
48 | |
49 | before orig => sub { |
50 | push @seen, "before 2"; |
51 | }; |
52 | |
53 | around orig => sub { |
54 | my $orig = shift; |
55 | push @seen, "around 1 before"; |
56 | $orig->(); |
57 | push @seen, "around 1 after"; |
58 | }; |
59 | |
60 | around orig => sub { |
61 | my $orig = shift; |
62 | push @seen, "around 2 before"; |
63 | $orig->(); |
64 | push @seen, "around 2 after"; |
65 | }; |
66 | |
67 | after orig => sub { |
68 | push @seen, "after 1"; |
69 | }; |
70 | |
71 | after orig => sub { |
72 | push @seen, "after 2"; |
73 | }; |
74 | } |
75 | |
76 | BEGIN { |
77 | package Grandchild; |
78 | use Mouse; |
79 | extends 'Child'; |
80 | |
81 | before orig => sub { |
82 | push @seen, "before 3"; |
83 | }; |
84 | |
85 | before orig => sub { |
86 | push @seen, "before 4"; |
87 | }; |
88 | |
89 | around orig => sub { |
90 | my $orig = shift; |
91 | push @seen, "around 3 before"; |
92 | $orig->(); |
93 | push @seen, "around 3 after"; |
94 | }; |
95 | |
96 | around orig => sub { |
97 | my $orig = shift; |
98 | push @seen, "around 4 before"; |
99 | $orig->(); |
100 | push @seen, "around 4 after"; |
101 | }; |
102 | |
103 | after orig => sub { |
104 | push @seen, "after 3"; |
105 | }; |
106 | |
107 | after orig => sub { |
108 | push @seen, "after 4"; |
109 | }; |
110 | } |
111 | |
43e6a50b |
112 | # from Class::Method::Modifers' t/020-multiple-inheritance.t |
113 | |
114 | # inheritance tree looks like: |
115 | # |
116 | # SuperL SuperR |
117 | # \ / |
118 | # MiddleL MiddleR |
119 | # \ / |
120 | # -Child- |
121 | |
122 | # the Child and MiddleR modules use modifiers |
123 | # Child will modify a method in SuperL (sl_c) |
124 | # Child will modify a method in SuperR (sr_c) |
125 | # Child will modify a method in SuperR already modified by MiddleR (sr_m_c) |
126 | # SuperL and MiddleR will both have a method of the same name, doing different |
127 | # things (called 'conflict' and 'cnf_mod') |
128 | |
129 | # every method and modifier will just return <Class:Method:STUFF> |
130 | |
131 | BEGIN |
132 | { |
133 | { |
134 | package SuperL; |
135 | use Mouse; |
136 | |
137 | sub superl { "<SuperL:superl>" } |
138 | sub conflict { "<SuperL:conflict>" } |
139 | sub cnf_mod { "<SuperL:cnf_mod>" } |
140 | sub sl_c { "<SuperL:sl_c>" } |
141 | } |
142 | |
143 | { |
144 | package SuperR; |
145 | use Mouse; |
146 | |
147 | sub superr { "<SuperR:superr>" } |
148 | sub sr_c { "<SuperR:sr_c>" } |
149 | sub sr_m_c { "<SuperR:sr_m_c>" } |
150 | } |
151 | |
152 | { |
153 | package MiddleL; |
154 | use Mouse; |
155 | extends 'SuperL'; |
156 | |
157 | sub middlel { "<MiddleL:middlel>" } |
158 | } |
159 | |
160 | { |
161 | package MiddleR; |
162 | use Mouse; |
163 | extends 'SuperR'; |
164 | |
165 | sub middler { "<MiddleR:middler>" } |
166 | sub conflict { "<MiddleR:conflict>" } |
167 | sub cnf_mod { "<MiddleR:cnf_mod>" } |
168 | around sr_m_c => sub { |
169 | my $orig = shift; |
170 | return "<MiddleR:sr_m_c:".$orig->(@_).">" |
171 | }; |
172 | } |
173 | |
174 | { |
175 | package Child; |
176 | use Mouse; |
177 | extends qw(MiddleL MiddleR); |
178 | |
179 | sub child { "<Child:child>" } |
180 | around cnf_mod => sub { "<Child:cnf_mod:".shift->(@_).">" }; |
181 | around sl_c => sub { "<Child:sl_c:".shift->(@_).">" }; |
182 | around sr_c => sub { "<Child:sr_c:".shift->(@_).">" }; |
183 | around sr_m_c => sub { |
184 | my $orig = shift; |
185 | return "<Child:sr_m_c:".$orig->(@_).">" |
186 | }; |
187 | } |
188 | } |
189 | |
190 | |
191 | my $SuperL = SuperL->new(); |
192 | my $SuperR = SuperR->new(); |
193 | my $MiddleL = MiddleL->new(); |
194 | my $MiddleR = MiddleR->new(); |
195 | my $Child = Child->new(); |
196 | |
197 | is($SuperL->superl, "<SuperL:superl>", "SuperL loaded correctly"); |
198 | is($SuperR->superr, "<SuperR:superr>", "SuperR loaded correctly"); |
199 | is($MiddleL->middlel, "<MiddleL:middlel>", "MiddleL loaded correctly"); |
200 | is($MiddleR->middler, "<MiddleR:middler>", "MiddleR loaded correctly"); |
201 | is($Child->child, "<Child:child>", "Child loaded correctly"); |
202 | |
203 | is($SuperL->sl_c, "<SuperL:sl_c>", "SuperL->sl_c on SuperL"); |
204 | is($Child->sl_c, "<Child:sl_c:<SuperL:sl_c>>", "SuperL->sl_c wrapped by Child's around"); |
205 | |
206 | is($SuperR->sr_c, "<SuperR:sr_c>", "SuperR->sr_c on SuperR"); |
207 | is($Child->sr_c, "<Child:sr_c:<SuperR:sr_c>>", "SuperR->sr_c wrapped by Child's around"); |
208 | |
209 | is($SuperR->sr_m_c, "<SuperR:sr_m_c>", "SuperR->sr_m_c on SuperR"); |
210 | is($MiddleR->sr_m_c, "<MiddleR:sr_m_c:<SuperR:sr_m_c>>", "SuperR->sr_m_c wrapped by MiddleR's around"); |
211 | is($Child->sr_m_c, "<Child:sr_m_c:<MiddleR:sr_m_c:<SuperR:sr_m_c>>>", "MiddleR->sr_m_c's wrapping wrapped by Child's around"); |
212 | |
213 | is($SuperL->conflict, "<SuperL:conflict>", "SuperL->conflict on SuperL"); |
214 | is($MiddleR->conflict, "<MiddleR:conflict>", "MiddleR->conflict on MiddleR"); |
215 | is($Child->conflict, "<SuperL:conflict>", "SuperL->conflict on Child"); |
216 | |
217 | is($SuperL->cnf_mod, "<SuperL:cnf_mod>", "SuperL->cnf_mod on SuperL"); |
218 | is($MiddleR->cnf_mod, "<MiddleR:cnf_mod>", "MiddleR->cnf_mod on MiddleR"); |
219 | is($Child->cnf_mod, "<Child:cnf_mod:<SuperL:cnf_mod>>", "SuperL->cnf_mod wrapped by Child's around"); |
220 | |
221 | # taken from Class::Method::Modifiers' t/051-undef-list-ctxt.t |
222 | my($orig_called, $after_called); |
223 | BEGIN |
224 | { |
225 | package ParentX; |
226 | use Mouse; |
227 | |
228 | sub orig |
229 | { |
230 | my $self = shift; |
231 | $orig_called = 1; |
232 | return; |
233 | } |
234 | |
235 | package ChildX; |
236 | use Mouse; |
237 | extends 'ParentX'; |
238 | |
239 | after 'orig' => sub |
240 | { |
241 | $after_called = 1; |
242 | }; |
243 | } |
244 | |
245 | { |
246 | ($after_called, $orig_called) = (0, 0); |
247 | my $child = ChildX->new(); |
248 | my @results = $child->orig(); |
249 | |
250 | ok($orig_called, "original method called"); |
251 | ok($after_called, "after-modifier called"); |
252 | is(@results, 0, "list context with after doesn't screw up 'return'"); |
253 | |
254 | ($after_called, $orig_called) = (0, 0); |
255 | my $result = $child->orig(); |
256 | |
257 | ok($orig_called, "original method called"); |
258 | ok($after_called, "after-modifier called"); |
259 | is($result, undef, "scalar context with after doesn't screw up 'return'"); |
260 | } |