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