6 use Test::Requires 'Data::Visitor';
7 use Test::Requires 'PadWalker';
9 my $can_partialdump = try {
10 Class::MOP::load_class('Devel::PartialDump', { -version => 0.14 }); 1;
14 package Test::Visitor;
16 use Moose::Util::TypeConstraints;
17 extends 'Data::Visitor';
22 default => sub { [] },
24 add_closed_over => 'push',
25 closed_over => 'elements',
30 before visit_code => sub {
33 my $closed_over = PadWalker::closed_over($code);
34 $self->visit_ref($closed_over);
41 $self->add_closed_over($thing)
42 unless $self->_is_okay_to_close_over($thing);
45 sub _is_okay_to_close_over {
49 match_on_type $thing => (
50 'RegexpRef' => sub { 1 },
51 'Object' => sub { 0 },
52 'GlobRef' => sub { 0 },
53 'FileHandle' => sub { 0 },
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);
66 pass("${package}::${method} didn't close over anything complicated");
69 fail("${package}::${method} closed over some stuff:");
70 my @closed_over = $visitor->closed_over;
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);
79 diag("... and " . scalar(@closed_over) . " more")
87 use Moose::Util::TypeConstraints;
102 isa => 'ArrayRef[Num]',
103 default => sub { [ 1.2 ] },
104 trigger => sub { warn "blah" },
110 message { "must be less than 5" };
114 predicate => 'has_quux',
115 clearer => 'clear_quux',
118 __PACKAGE__->meta->make_immutable;
121 close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux);
134 after bar => sub { };
135 before baz => sub { };
136 override quux => sub { super };
140 __PACKAGE__->meta->make_immutable;
143 close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah);
146 package Foo::Sub::Sub;
150 augment blah => { inner };
152 __PACKAGE__->meta->make_immutable;
155 close_over_ok('Foo::Sub::Sub', $_) for qw(new blah);
161 elements => 'elements',
162 is_empty => 'is_empty',
164 push_curried => [ push => 42, 84 ],
165 unshift => 'unshift',
166 unshift_curried => [ unshift => 42, 84 ],
170 get_curried => [ get => 1 ],
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 ) ],
179 delete_curried => [ delete => 1 ],
181 insert_curried => [ insert => ( 1, 101 ) ],
183 splice_curried_1 => [ splice => 1 ],
184 splice_curried_2 => [ splice => 1, 2 ],
185 splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
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] } ) ],
192 map_curried => [ map => ( sub { $_ + 1 } ) ],
194 grep_curried => [ grep => ( sub { $_ < 5 } ) ],
196 first_curried => [ first => ( sub { $_ % 2 } ) ],
198 join_curried => [ join => '-' ],
199 shuffle => 'shuffle',
202 reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
203 natatime => 'natatime',
204 natatime_curried => [ natatime => 2 ],
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',
216 has_no_options => 'is_empty',
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 ],
236 cut_in_half => [ div => 2 ],
247 flip_switch => 'toggle',
253 append_curried => [ append => '!' ],
254 prepend => 'prepend',
255 prepend_curried => [ prepend => '-' ],
256 replace => 'replace',
257 replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
262 match_curried => [ match => qr/\D/ ],
265 substr_curried_1 => [ substr => (1) ],
266 substr_curried_2 => [ substr => ( 1, 3 ) ],
267 substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
270 execute => 'execute',
271 execute_method => 'execute_method',
276 Array => 'ArrayRef[Str]',
277 Hash => 'HashRef[Int]',
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",
302 Moose::Meta::Class->create(
304 superclasses => ['Moose::Object'],
310 default => sub { $default{$trait} },
312 map {; "nonlazy_$_" => $handles->{$_} } keys %$handles
320 default => sub { $default{$trait} },
322 map {; "lazy_$_" => $handles->{$_} } keys %$handles
327 close_over_ok($class_name, $_) for (
329 map {; "nonlazy_$_", "lazy_$_" } keys %$handles
335 package WithInitializer;
341 initializer => sub { },
348 default => sub { 'a' },
349 initializer => sub { },
352 __PACKAGE__->meta->make_immutable;
355 close_over_ok('WithInitializer', 'foo');
356 { local $TODO = "initializer still closes over things";
357 close_over_ok('WithInitializer', $_) for qw(new bar);
361 package CustomErrorClass;
363 extends 'Moose::Error::Default';
367 package WithCustomErrorClass;
369 metaclass => 'Moose::Meta::Class',
370 error_class => 'CustomErrorClass',
379 __PACKAGE__->meta->make_immutable;
382 { local $TODO = "custom error classes still close over things";
383 close_over_ok('WithCustomErrorClass', $_) for qw(new foo);