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 {
50 match_on_type $thing => (
51 'RegexpRef' => sub { 1 },
52 'Object' => sub { 0 },
53 'GlobRef' => sub { 0 },
54 'FileHandle' => sub { 0 },
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);
67 pass("${package}::${method} didn't close over anything complicated");
70 fail("${package}::${method} closed over some stuff:");
71 my @closed_over = $visitor->closed_over;
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);
80 diag("... and " . scalar(@closed_over) . " more")
88 use Moose::Util::TypeConstraints;
103 isa => 'ArrayRef[Num]',
104 default => sub { [ 1.2 ] },
105 trigger => sub { warn "blah" },
111 message { "must be less than 5" };
115 predicate => 'has_quux',
116 clearer => 'clear_quux',
119 __PACKAGE__->meta->make_immutable;
122 close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux);
135 after bar => sub { };
136 before baz => sub { };
137 override quux => sub { super };
141 __PACKAGE__->meta->make_immutable;
144 close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah);
147 package Foo::Sub::Sub;
151 augment blah => { inner };
153 __PACKAGE__->meta->make_immutable;
156 close_over_ok('Foo::Sub::Sub', $_) for qw(new blah);
162 elements => 'elements',
163 is_empty => 'is_empty',
165 push_curried => [ push => 42, 84 ],
166 unshift => 'unshift',
167 unshift_curried => [ unshift => 42, 84 ],
171 get_curried => [ get => 1 ],
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 ) ],
180 delete_curried => [ delete => 1 ],
182 insert_curried => [ insert => ( 1, 101 ) ],
184 splice_curried_1 => [ splice => 1 ],
185 splice_curried_2 => [ splice => 1, 2 ],
186 splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
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] } ) ],
193 map_curried => [ map => ( sub { $_ + 1 } ) ],
195 grep_curried => [ grep => ( sub { $_ < 5 } ) ],
197 first_curried => [ first => ( sub { $_ % 2 } ) ],
199 join_curried => [ join => '-' ],
200 shuffle => 'shuffle',
203 reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
204 natatime => 'natatime',
205 natatime_curried => [ natatime => 2 ],
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',
217 has_no_options => 'is_empty',
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 ],
237 cut_in_half => [ div => 2 ],
248 flip_switch => 'toggle',
254 append_curried => [ append => '!' ],
255 prepend => 'prepend',
256 prepend_curried => [ prepend => '-' ],
257 replace => 'replace',
258 replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
263 match_curried => [ match => qr/\D/ ],
266 substr_curried_1 => [ substr => (1) ],
267 substr_curried_2 => [ substr => ( 1, 3 ) ],
268 substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
271 execute => 'execute',
272 execute_method => 'execute_method',
277 Array => 'ArrayRef[Str]',
278 Hash => 'HashRef[Int]',
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",
303 Moose::Meta::Class->create(
305 superclasses => ['Moose::Object'],
311 default => sub { $default{$trait} },
313 map {; "nonlazy_$_" => $handles->{$_} } keys %$handles
321 default => sub { $default{$trait} },
323 map {; "lazy_$_" => $handles->{$_} } keys %$handles
328 close_over_ok($class_name, $_) for (
330 map {; "nonlazy_$_", "lazy_$_" } keys %$handles
336 package WithInitializer;
342 initializer => sub { },
349 default => sub { 'a' },
350 initializer => sub { },
353 __PACKAGE__->meta->make_immutable;
356 close_over_ok('WithInitializer', 'foo');
357 { local $TODO = "initializer still closes over things";
358 close_over_ok('WithInitializer', $_) for qw(new bar);
362 package CustomErrorClass;
364 extends 'Moose::Error::Default';
368 package WithCustomErrorClass;
370 metaclass => 'Moose::Meta::Class',
371 error_class => 'CustomErrorClass',
380 __PACKAGE__->meta->make_immutable;
383 { local $TODO = "custom error classes still close over things";
384 close_over_ok('WithCustomErrorClass', $_) for qw(new foo);