Commit | Line | Data |
46c48e08 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | |
6 | BEGIN { |
7 | eval "use Test::Output;"; |
8 | plan skip_all => "Test::Output is required for this test" if $@; |
46c48e08 |
9 | } |
10 | |
11 | use Class::MOP; |
12 | |
13 | { |
14 | package HasConstructor; |
15 | |
16 | sub new { bless {}, $_[0] } |
17 | |
18 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
19 | |
20 | $meta->superclasses('NotMoose'); |
21 | |
22 | ::stderr_like( |
23 | sub { $meta->make_immutable }, |
24 | qr/\QNot inlining a constructor for HasConstructor since it defines its own constructor.\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to HasConstructor->meta->make_immutable\E/, |
25 | 'got a warning that Foo will not have an inlined constructor because it defines its own new method' |
26 | ); |
27 | |
28 | ::is( |
29 | $meta->find_method_by_name('new')->body, |
30 | HasConstructor->can('new'), |
31 | 'HasConstructor->new was untouched' |
32 | ); |
33 | } |
34 | |
35 | { |
36 | package My::Constructor; |
37 | |
38 | use base 'Class::MOP::Method::Constructor'; |
39 | |
40 | sub _expected_method_class { 'Base::Class' } |
41 | } |
42 | |
43 | { |
44 | package No::Constructor; |
45 | } |
46 | |
47 | { |
48 | package My::Constructor2; |
49 | |
50 | use base 'Class::MOP::Method::Constructor'; |
51 | |
52 | sub _expected_method_class { 'No::Constructor' } |
53 | } |
54 | |
55 | { |
56 | package Base::Class; |
57 | |
58 | sub new { bless {}, $_[0] } |
59 | sub DESTROY { } |
60 | } |
61 | |
62 | { |
63 | package NotMoose; |
64 | |
65 | sub new { |
66 | my $class = shift; |
67 | |
68 | return bless { not_moose => 1 }, $class; |
69 | } |
70 | } |
71 | |
72 | { |
73 | package Foo; |
74 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
75 | |
76 | $meta->superclasses('NotMoose'); |
77 | |
78 | ::stderr_like( |
79 | sub { $meta->make_immutable( constructor_class => 'My::Constructor' ) }, |
80 | qr/\QNot inlining 'new' for Foo since it is not inheriting the default Base::Class::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, |
81 | 'got a warning that Foo will not have an inlined constructor' |
82 | ); |
83 | |
84 | ::is( |
85 | $meta->find_method_by_name('new')->body, |
86 | NotMoose->can('new'), |
87 | 'Foo->new is inherited from NotMoose' |
88 | ); |
89 | } |
90 | |
91 | { |
92 | package Bar; |
93 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
94 | |
95 | $meta->superclasses('NotMoose'); |
96 | |
97 | ::stderr_is( |
98 | sub { $meta->make_immutable( replace_constructor => 1 ) }, |
99 | q{}, |
100 | 'no warning when replace_constructor is true' |
101 | ); |
102 | |
103 | ::is( |
104 | $meta->find_method_by_name('new')->package_name, |
105 | 'Bar', |
106 | 'Bar->new is inlined, and not inherited from NotMoose' |
107 | ); |
108 | } |
109 | |
110 | { |
111 | package Baz; |
112 | Class::MOP::Class->initialize(__PACKAGE__)->make_immutable; |
113 | } |
114 | |
115 | { |
116 | package Quux; |
117 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
118 | |
119 | $meta->superclasses('Baz'); |
120 | |
121 | ::stderr_is( |
122 | sub { $meta->make_immutable }, |
123 | q{}, |
124 | 'no warning when inheriting from a class that has already made itself immutable' |
125 | ); |
126 | } |
127 | |
128 | { |
129 | package Whatever; |
130 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
131 | |
132 | ::stderr_like( |
133 | sub { $meta->make_immutable( constructor_class => 'My::Constructor2' ) }, |
134 | qr/\QNot inlining 'new' for Whatever since No::Constructor::new is not defined/, |
135 | 'got a warning that Whatever will not have an inlined constructor because its expected inherited method does not exist' |
136 | ); |
137 | } |
138 | |
139 | { |
140 | package My::Constructor3; |
141 | |
142 | use base 'Class::MOP::Method::Constructor'; |
143 | } |
144 | |
145 | { |
146 | package CustomCons; |
147 | |
148 | Class::MOP::Class->initialize(__PACKAGE__)->make_immutable( constructor_class => 'My::Constructor3' ); |
149 | } |
150 | |
151 | { |
152 | package Subclass; |
153 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
154 | |
155 | $meta->superclasses('CustomCons'); |
156 | |
157 | ::stderr_is( |
158 | sub { $meta->make_immutable }, |
159 | q{}, |
160 | 'no warning when inheriting from a class that has already made itself immutable' |
161 | ); |
162 | } |
163 | |
164 | { |
165 | package ModdedNew; |
166 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
167 | |
168 | sub new { bless {}, shift } |
169 | |
170 | $meta->add_before_method_modifier( 'new' => sub { } ); |
171 | } |
172 | |
173 | { |
174 | package ModdedSub; |
175 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
176 | |
177 | $meta->superclasses('ModdedNew'); |
178 | |
179 | ::stderr_like( |
180 | sub { $meta->make_immutable }, |
181 | qr/\QNot inlining 'new' for ModdedSub since it has method modifiers which would be lost if it were inlined/, |
182 | 'got a warning that ModdedSub will not have an inlined constructor since it inherited a wrapped new' |
183 | ); |
184 | } |
185 | |
186 | { |
187 | package My::Destructor; |
188 | |
189 | use base 'Class::MOP::Method::Inlined'; |
190 | |
191 | sub new { |
192 | my $class = shift; |
193 | my %options = @_; |
194 | |
195 | my $self = bless \%options, $class; |
196 | $self->_inline_destructor; |
197 | |
198 | return $self; |
199 | } |
200 | |
201 | sub _inline_destructor { |
202 | my $self = shift; |
203 | |
e24b19fb |
204 | my ( $code, $e ) = $self->_eval_closure( {}, 'sub { }' ); |
205 | die $e if $e; |
46c48e08 |
206 | |
207 | $self->{body} = $code; |
208 | } |
209 | |
210 | sub is_needed { 1 } |
211 | sub associated_metaclass { $_[0]->{metaclass} } |
e24b19fb |
212 | sub body { $_[0]->{body} } |
46c48e08 |
213 | sub _expected_method_class { 'Base::Class' } |
214 | } |
215 | |
216 | { |
217 | package HasDestructor; |
218 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
219 | |
220 | sub DESTROY { } |
221 | |
222 | ::stderr_like( |
223 | sub { |
224 | $meta->make_immutable( |
225 | inline_destructor => 1, |
226 | destructor_class => 'My::Destructor', |
227 | ); |
228 | }, |
229 | qr/Not inlining a destructor for HasDestructor since it defines its own destructor./, |
230 | 'got a warning when trying to inline a destructor for a class that already defines DESTROY' |
231 | ); |
232 | |
233 | ::is( |
234 | $meta->find_method_by_name('DESTROY')->body, |
235 | HasDestructor->can('DESTROY'), |
236 | 'HasDestructor->DESTROY was untouched' |
237 | ); |
238 | } |
239 | |
240 | { |
241 | package HasDestructor2; |
242 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
243 | |
244 | sub DESTROY { } |
245 | |
246 | $meta->make_immutable( |
247 | inline_destructor => 1, |
248 | destructor_class => 'My::Destructor', |
249 | replace_destructor => 1 |
250 | ); |
251 | |
252 | ::stderr_is( |
253 | sub { |
254 | $meta->make_immutable( |
255 | inline_destructor => 1, |
256 | destructor_class => 'My::Destructor', |
257 | replace_destructor => 1 |
258 | ); |
259 | }, |
260 | q{}, |
261 | 'no warning when replace_destructor is true' |
262 | ); |
263 | |
264 | ::isnt( |
265 | $meta->find_method_by_name('new')->body, |
266 | HasConstructor2->can('new'), |
267 | 'HasConstructor2->new was replaced' |
268 | ); |
269 | } |
270 | |
271 | { |
272 | package ParentHasDestructor; |
273 | |
274 | sub DESTROY { } |
275 | } |
276 | |
277 | { |
278 | package DestructorChild; |
279 | |
280 | use base 'ParentHasDestructor'; |
281 | |
282 | my $meta = Class::MOP::Class->initialize(__PACKAGE__); |
283 | |
284 | ::stderr_like( |
285 | sub { |
286 | $meta->make_immutable( |
287 | inline_destructor => 1, |
288 | destructor_class => 'My::Destructor', |
289 | ); |
290 | }, |
291 | qr/Not inlining 'DESTROY' for DestructorChild since it is not inheriting the default Base::Class::DESTROY/, |
292 | 'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY' |
293 | ); |
294 | } |
86a4d873 |
295 | |
296 | done_testing; |