6 use Class::Load 'load_class';
7 use Test::Requires 'Data::Visitor';
8 use Test::Requires 'PadWalker';
10 my $can_partialdump = try {
11 load_class('Devel::PartialDump', { -version => 0.14 }); 1;
15 package Test::Visitor;
17 use Moose::Util::TypeConstraints;
18 extends 'Data::Visitor';
23 default => sub { [] },
25 add_closed_over => 'push',
26 closed_over => 'elements',
31 before visit_code => sub {
34 my $closed_over = PadWalker::closed_over($code);
35 $self->visit_ref($closed_over);
42 $self->add_closed_over($thing)
43 unless $self->_is_okay_to_close_over($thing);
46 sub _is_okay_to_close_over {
49 return 1 if ref($thing) eq 'RuNNeR';
51 match_on_type $thing => (
52 'RegexpRef' => sub { 1 },
53 'Object' => sub { 0 },
54 'GlobRef' => sub { 0 },
55 'FileHandle' => sub { 0 },
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;
66 $code = $code->(undef, $code) if ref($code) eq 'RuNNeR';
67 $visitor->visit($code);
69 pass("${package}::${method} didn't close over anything complicated");
72 fail("${package}::${method} closed over some stuff:");
73 my @closed_over = $visitor->closed_over;
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);
82 diag("... and " . scalar(@closed_over) . " more")
90 use Moose::Util::TypeConstraints;
105 isa => 'ArrayRef[Num]',
106 default => sub { [ 1.2 ] },
107 trigger => sub { warn "blah" },
113 message { "must be less than 5" };
117 predicate => 'has_quux',
118 clearer => 'clear_quux',
121 __PACKAGE__->meta->make_immutable;
124 close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux);
137 after bar => sub { };
138 before baz => sub { };
139 override quux => sub { super };
143 __PACKAGE__->meta->make_immutable;
146 close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah);
149 package Foo::Sub::Sub;
153 augment blah => { inner };
155 __PACKAGE__->meta->make_immutable;
158 close_over_ok('Foo::Sub::Sub', $_) for qw(new blah);
164 elements => 'elements',
165 is_empty => 'is_empty',
167 push_curried => [ push => 42, 84 ],
168 unshift => 'unshift',
169 unshift_curried => [ unshift => 42, 84 ],
173 get_curried => [ get => 1 ],
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 ) ],
182 delete_curried => [ delete => 1 ],
184 insert_curried => [ insert => ( 1, 101 ) ],
186 splice_curried_1 => [ splice => 1 ],
187 splice_curried_2 => [ splice => 1, 2 ],
188 splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
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] } ) ],
195 map_curried => [ map => ( sub { $_ + 1 } ) ],
197 grep_curried => [ grep => ( sub { $_ < 5 } ) ],
199 first_curried => [ first => ( sub { $_ % 2 } ) ],
201 join_curried => [ join => '-' ],
202 shuffle => 'shuffle',
205 reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
206 natatime => 'natatime',
207 natatime_curried => [ natatime => 2 ],
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',
219 has_no_options => 'is_empty',
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 ],
239 cut_in_half => [ div => 2 ],
250 flip_switch => 'toggle',
256 append_curried => [ append => '!' ],
257 prepend => 'prepend',
258 prepend_curried => [ prepend => '-' ],
259 replace => 'replace',
260 replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
265 match_curried => [ match => qr/\D/ ],
268 substr_curried_1 => [ substr => (1) ],
269 substr_curried_2 => [ substr => ( 1, 3 ) ],
270 substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
273 execute => 'execute',
274 execute_method => 'execute_method',
279 Array => 'ArrayRef[Str]',
280 Hash => 'HashRef[Int]',
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",
305 Moose::Meta::Class->create(
307 superclasses => ['Moose::Object'],
313 default => sub { $default{$trait} },
315 map {; "nonlazy_$_" => $handles->{$_} } keys %$handles
323 default => sub { $default{$trait} },
325 map {; "lazy_$_" => $handles->{$_} } keys %$handles
330 close_over_ok($class_name, $_) for (
332 map {; "nonlazy_$_", "lazy_$_" } keys %$handles
338 package WithInitializer;
344 initializer => sub { },
351 default => sub { 'a' },
352 initializer => sub { },
355 __PACKAGE__->meta->make_immutable;
358 close_over_ok('WithInitializer', 'foo');
359 { local $TODO = "initializer still closes over things";
360 close_over_ok('WithInitializer', $_) for qw(new bar);
364 package CustomErrorClass;
366 extends 'Moose::Error::Default';
370 package WithCustomErrorClass;
372 metaclass => 'Moose::Meta::Class',
373 error_class => 'CustomErrorClass',
382 __PACKAGE__->meta->make_immutable;
385 { local $TODO = "custom error classes still close over things";
386 close_over_ok('WithCustomErrorClass', $_) for qw(new foo);