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