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