Commit | Line | Data |
4d9b02de |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More; |
5 | |
6 | use Test::Requires 'Data::Visitor'; |
7 | use Test::Requires 'PadWalker'; |
8 | use Try::Tiny; |
9 | my $can_partialdump = try { |
10 | Class::MOP::load_class('Devel::PartialDump', { -version => 0.14 }); 1; |
11 | }; |
12 | |
13 | { |
14 | package Test::Visitor; |
15 | use Moose; |
16 | use Moose::Util::TypeConstraints; |
17 | extends 'Data::Visitor'; |
18 | |
19 | has closed_over => ( |
20 | traits => ['Array'], |
21 | isa => 'ArrayRef', |
22 | default => sub { [] }, |
23 | handles => { |
24 | add_closed_over => 'push', |
25 | closed_over => 'elements', |
26 | pass => 'is_empty', |
27 | }, |
28 | ); |
29 | |
30 | before visit_code => sub { |
31 | my $self = shift; |
32 | my ($code) = @_; |
33 | my $closed_over = PadWalker::closed_over($code); |
34 | $self->visit_ref($closed_over); |
35 | }; |
36 | |
37 | after visit => sub { |
38 | my $self = shift; |
39 | my ($thing) = @_; |
40 | |
41 | $self->add_closed_over($thing) |
42 | unless $self->_is_okay_to_close_over($thing); |
43 | }; |
44 | |
45 | sub _is_okay_to_close_over { |
46 | my $self = shift; |
47 | my ($thing) = @_; |
48 | |
49 | match_on_type $thing => ( |
50 | 'RegexpRef' => sub { 1 }, |
51 | 'Object' => sub { 0 }, |
52 | 'GlobRef' => sub { 0 }, |
53 | 'FileHandle' => sub { 0 }, |
54 | 'Any' => sub { 1 }, |
55 | ); |
56 | } |
57 | } |
58 | |
59 | sub close_over_ok { |
60 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
61 | my ($package, $method) = @_; |
62 | my $visitor = Test::Visitor->new; |
63 | my $code = $package->meta->find_method_by_name($method)->body; |
64 | $visitor->visit($code); |
65 | if ($visitor->pass) { |
66 | pass("${package}::${method} didn't close over anything complicated"); |
67 | } |
68 | else { |
69 | fail("${package}::${method} closed over some stuff:"); |
70 | my @closed_over = $visitor->closed_over; |
71 | for my $i (1..10) { |
72 | last unless @closed_over; |
73 | my $closed_over = shift @closed_over; |
74 | if ($can_partialdump) { |
75 | $closed_over = Devel::PartialDump->new->dump($closed_over); |
76 | } |
77 | diag($closed_over); |
78 | } |
79 | diag("... and " . scalar(@closed_over) . " more") |
80 | if @closed_over; |
81 | } |
82 | } |
83 | |
84 | { |
85 | package Foo; |
86 | use Moose; |
87 | use Moose::Util::TypeConstraints; |
88 | |
89 | has foo => ( |
90 | is => 'ro', |
91 | isa => 'Str', |
92 | ); |
93 | |
94 | has bar => ( |
95 | is => 'ro', |
96 | isa => 'Int', |
97 | default => 1, |
98 | ); |
99 | |
100 | has baz => ( |
101 | is => 'rw', |
102 | isa => 'ArrayRef[Num]', |
103 | default => sub { [ 1.2 ] }, |
104 | trigger => sub { warn "blah" }, |
105 | ); |
106 | |
107 | subtype 'Thing', |
108 | as 'Int', |
109 | where { $_ < 5 }, |
110 | message { "must be less than 5" }; |
111 | has quux => ( |
112 | is => 'rw', |
113 | isa => 'Thing', |
114 | predicate => 'has_quux', |
115 | clearer => 'clear_quux', |
116 | ); |
117 | |
118 | __PACKAGE__->meta->make_immutable; |
119 | } |
120 | |
121 | close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux); |
122 | |
123 | { |
124 | package Foo::Sub; |
125 | use Moose; |
126 | extends 'Foo'; |
127 | |
128 | around foo => sub { |
129 | my $orig = shift; |
130 | my $self = shift; |
131 | $self->$orig(@_); |
132 | }; |
133 | |
134 | after bar => sub { }; |
135 | before baz => sub { }; |
136 | override quux => sub { super }; |
137 | |
138 | sub blah { inner } |
139 | |
140 | __PACKAGE__->meta->make_immutable; |
141 | } |
142 | |
143 | close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah); |
144 | |
145 | { |
146 | package Foo::Sub::Sub; |
147 | use Moose; |
148 | extends 'Foo::Sub'; |
149 | |
150 | augment blah => { inner }; |
151 | |
152 | __PACKAGE__->meta->make_immutable; |
153 | } |
154 | |
155 | close_over_ok('Foo::Sub::Sub', $_) for qw(new blah); |
156 | |
157 | { |
158 | my %handles = ( |
159 | Array => { |
160 | count => 'count', |
161 | elements => 'elements', |
162 | is_empty => 'is_empty', |
163 | push => 'push', |
164 | push_curried => [ push => 42, 84 ], |
165 | unshift => 'unshift', |
166 | unshift_curried => [ unshift => 42, 84 ], |
167 | pop => 'pop', |
168 | shift => 'shift', |
169 | get => 'get', |
170 | get_curried => [ get => 1 ], |
171 | set => 'set', |
172 | set_curried_1 => [ set => 1 ], |
173 | set_curried_2 => [ set => ( 1, 98 ) ], |
174 | accessor => 'accessor', |
175 | accessor_curried_1 => [ accessor => 1 ], |
176 | accessor_curried_2 => [ accessor => ( 1, 90 ) ], |
177 | clear => 'clear', |
178 | delete => 'delete', |
179 | delete_curried => [ delete => 1 ], |
180 | insert => 'insert', |
181 | insert_curried => [ insert => ( 1, 101 ) ], |
182 | splice => 'splice', |
183 | splice_curried_1 => [ splice => 1 ], |
184 | splice_curried_2 => [ splice => 1, 2 ], |
185 | splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], |
186 | sort => 'sort', |
187 | sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], |
188 | sort_in_place => 'sort_in_place', |
189 | sort_in_place_curried => |
190 | [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], |
191 | map => 'map', |
192 | map_curried => [ map => ( sub { $_ + 1 } ) ], |
193 | grep => 'grep', |
194 | grep_curried => [ grep => ( sub { $_ < 5 } ) ], |
195 | first => 'first', |
196 | first_curried => [ first => ( sub { $_ % 2 } ) ], |
197 | join => 'join', |
198 | join_curried => [ join => '-' ], |
199 | shuffle => 'shuffle', |
200 | uniq => 'uniq', |
201 | reduce => 'reduce', |
202 | reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], |
203 | natatime => 'natatime', |
204 | natatime_curried => [ natatime => 2 ], |
205 | }, |
206 | Hash => { |
207 | option_accessor => 'accessor', |
208 | quantity => [ accessor => 'quantity' ], |
209 | clear_options => 'clear', |
210 | num_options => 'count', |
211 | delete_option => 'delete', |
212 | is_defined => 'defined', |
213 | options_elements => 'elements', |
214 | has_option => 'exists', |
215 | get_option => 'get', |
216 | has_no_options => 'is_empty', |
217 | keys => 'keys', |
218 | values => 'values', |
219 | key_value => 'kv', |
220 | set_option => 'set', |
221 | }, |
222 | Counter => { |
223 | inc_counter => 'inc', |
224 | inc_counter_2 => [ inc => 2 ], |
225 | dec_counter => 'dec', |
226 | dec_counter_2 => [ dec => 2 ], |
227 | reset_counter => 'reset', |
228 | set_counter => 'set', |
229 | set_counter_42 => [ set => 42 ], |
230 | }, |
231 | Number => { |
232 | abs => 'abs', |
233 | add => 'add', |
234 | inc => [ add => 1 ], |
235 | div => 'div', |
236 | cut_in_half => [ div => 2 ], |
237 | mod => 'mod', |
238 | odd => [ mod => 2 ], |
239 | mul => 'mul', |
240 | set => 'set', |
241 | sub => 'sub', |
242 | dec => [ sub => 1 ], |
243 | }, |
244 | Bool => { |
245 | illuminate => 'set', |
246 | darken => 'unset', |
247 | flip_switch => 'toggle', |
248 | is_dark => 'not', |
249 | }, |
250 | String => { |
251 | inc => 'inc', |
252 | append => 'append', |
253 | append_curried => [ append => '!' ], |
254 | prepend => 'prepend', |
255 | prepend_curried => [ prepend => '-' ], |
256 | replace => 'replace', |
257 | replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], |
258 | chop => 'chop', |
259 | chomp => 'chomp', |
260 | clear => 'clear', |
261 | match => 'match', |
262 | match_curried => [ match => qr/\D/ ], |
263 | length => 'length', |
264 | substr => 'substr', |
265 | substr_curried_1 => [ substr => (1) ], |
266 | substr_curried_2 => [ substr => ( 1, 3 ) ], |
267 | substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], |
268 | }, |
269 | Code => { |
270 | execute => 'execute', |
271 | execute_method => 'execute_method', |
272 | }, |
273 | ); |
274 | |
275 | my %isa = ( |
276 | Array => 'ArrayRef[Str]', |
277 | Hash => 'HashRef[Int]', |
278 | Counter => 'Int', |
279 | Number => 'Num', |
280 | Bool => 'Bool', |
281 | String => 'Str', |
282 | Code => 'CodeRef', |
283 | ); |
284 | |
285 | my %default = ( |
286 | Array => [], |
287 | Hash => {}, |
288 | Counter => 0, |
289 | Number => 0.0, |
290 | Bool => 1, |
291 | String => '', |
292 | Code => sub { }, |
293 | ); |
294 | |
295 | for my $trait (keys %default) { |
296 | my $class_name = "Native::$trait"; |
297 | my $handles = $handles{$trait}; |
298 | my $attr_class = Moose::Util::with_traits( |
299 | 'Moose::Meta::Attribute', |
300 | "Moose::Meta::Attribute::Native::Trait::$trait", |
301 | ); |
302 | Moose::Meta::Class->create( |
303 | $class_name, |
304 | superclasses => ['Moose::Object'], |
305 | attributes => [ |
306 | $attr_class->new( |
307 | 'nonlazy', |
308 | is => 'ro', |
309 | isa => $isa{$trait}, |
310 | default => sub { $default{$trait} }, |
311 | handles => { |
312 | map {; "nonlazy_$_" => $handles->{$_} } keys %$handles |
313 | }, |
314 | ), |
315 | $attr_class->new( |
316 | 'lazy', |
317 | is => 'ro', |
318 | isa => $isa{$trait}, |
319 | lazy => 1, |
320 | default => sub { $default{$trait} }, |
321 | handles => { |
322 | map {; "lazy_$_" => $handles->{$_} } keys %$handles |
323 | }, |
324 | ), |
325 | ], |
326 | ); |
327 | close_over_ok($class_name, $_) for ( |
328 | 'new', |
329 | map {; "nonlazy_$_", "lazy_$_" } keys %$handles |
330 | ); |
331 | } |
332 | } |
333 | |
334 | { |
335 | package WithInitializer; |
336 | use Moose; |
337 | |
338 | has foo => ( |
339 | is => 'ro', |
340 | isa => 'Str', |
341 | initializer => sub { }, |
342 | ); |
343 | |
344 | has bar => ( |
345 | is => 'ro', |
346 | isa => 'Str', |
347 | lazy => 1, |
348 | default => sub { 'a' }, |
349 | initializer => sub { }, |
350 | ); |
351 | |
352 | __PACKAGE__->meta->make_immutable; |
353 | } |
354 | |
355 | close_over_ok('WithInitializer', 'foo'); |
356 | { local $TODO = "initializer still closes over things"; |
357 | close_over_ok('WithInitializer', $_) for qw(new bar); |
358 | } |
359 | |
360 | BEGIN { |
361 | package CustomErrorClass; |
362 | use Moose; |
363 | extends 'Moose::Error::Default'; |
364 | } |
365 | |
366 | { |
367 | package WithCustomErrorClass; |
368 | use metaclass ( |
369 | metaclass => 'Moose::Meta::Class', |
370 | error_class => 'CustomErrorClass', |
371 | ); |
372 | use Moose; |
373 | |
374 | has foo => ( |
375 | is => 'ro', |
376 | isa => 'Str', |
377 | ); |
378 | |
379 | __PACKAGE__->meta->make_immutable; |
380 | } |
381 | |
382 | { local $TODO = "custom error classes still close over things"; |
383 | close_over_ok('WithCustomErrorClass', $_) for qw(new foo); |
384 | } |
385 | |
386 | done_testing; |