[gitmo/Moose.git] / t / immutable / inline_close_over.t

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More;

use Class::Load 'load_class';
use Test::Requires 'Data::Visitor';
use Test::Requires 'PadWalker';
use Try::Tiny;
my $can_partialdump = try {
    load_class('Devel::PartialDump', { -version => 0.14 }); 1;
};

{
    package Test::Visitor;
    use Moose;
    use Moose::Util::TypeConstraints;
    extends 'Data::Visitor';

    has closed_over => (
        traits  => ['Array'],
        isa     => 'ArrayRef',
        default => sub { [] },
        handles => {
            add_closed_over => 'push',
            closed_over     => 'elements',
            pass            => 'is_empty',
        },
    );

    before visit_code => sub {
        my $self = shift;
        my ($code) = @_;
        my $closed_over = PadWalker::closed_over($code);
        $self->visit_ref($closed_over);
    };

    after visit => sub {
        my $self = shift;
        my ($thing) = @_;

        $self->add_closed_over($thing)
            unless $self->_is_okay_to_close_over($thing);
    };

    sub _is_okay_to_close_over {
        my $self = shift;
        my ($thing) = @_;
        return 1 if ref($thing) eq 'RuNNeR';

        match_on_type $thing => (
            'RegexpRef'  => sub { 1 },
            'Object'     => sub { 0 },
            'GlobRef'    => sub { 0 },
            'FileHandle' => sub { 0 },
            'Any'        => sub { 1 },
        );
    }
}

sub close_over_ok {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($package, $method) = @_;
    my $visitor = Test::Visitor->new;
    my $code = $package->meta->find_method_by_name($method)->body;
    if (ref($code) eq 'RuNNeR') {
        $code->(undef);
        $code = $package->meta->find_method_by_name($method)->body;
    }
    $visitor->visit($code);
    if ($visitor->pass) {
        pass("${package}::${method} didn't close over anything complicated");
    }
    else {
        fail("${package}::${method} closed over some stuff:");
        my @closed_over = $visitor->closed_over;
        for my $i (1..10) {
            last unless @closed_over;
            my $closed_over = shift @closed_over;
            if ($can_partialdump) {
                $closed_over = Devel::PartialDump->new->dump($closed_over);
            }
            diag($closed_over);
        }
        diag("... and " . scalar(@closed_over) . " more")
            if @closed_over;
    }
}

{
    package Foo;
    use Moose;
    use Moose::Util::TypeConstraints;

    has foo => (
        is  => 'ro',
        isa => 'Str',
    );

    has bar => (
        is      => 'ro',
        isa     => 'Int',
        default => 1,
    );

    has baz => (
        is      => 'rw',
        isa     => 'ArrayRef[Num]',
        default => sub { [ 1.2 ] },
        trigger => sub { warn "blah" },
    );

    subtype 'Thing',
         as 'Int',
         where { $_ < 5 },
         message { "must be less than 5" };
    has quux => (
        is        => 'rw',
        isa       => 'Thing',
        predicate => 'has_quux',
        clearer   => 'clear_quux',
    );

    __PACKAGE__->meta->make_immutable;
}

close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux);

{
    package Foo::Sub;
    use Moose;
    extends 'Foo';

    around foo => sub {
        my $orig = shift;
        my $self = shift;
        $self->$orig(@_);
    };

    after bar => sub { };
    before baz => sub { };
    override quux => sub { super };

    sub blah { inner }

    __PACKAGE__->meta->make_immutable;
}

close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah);

{
    package Foo::Sub::Sub;
    use Moose;
    extends 'Foo::Sub';

    augment blah => { inner };

    __PACKAGE__->meta->make_immutable;
}

close_over_ok('Foo::Sub::Sub', $_) for qw(new blah);

{
    my %handles = (
        Array   => {
            count                 => 'count',
            elements              => 'elements',
            is_empty              => 'is_empty',
            push                  => 'push',
            push_curried          => [ push => 42, 84 ],
            unshift               => 'unshift',
            unshift_curried       => [ unshift => 42, 84 ],
            pop                   => 'pop',
            shift                 => 'shift',
            get                   => 'get',
            get_curried           => [ get => 1 ],
            set                   => 'set',
            set_curried_1         => [ set => 1 ],
            set_curried_2         => [ set => ( 1, 98 ) ],
            accessor              => 'accessor',
            accessor_curried_1    => [ accessor => 1 ],
            accessor_curried_2    => [ accessor => ( 1, 90 ) ],
            clear                 => 'clear',
            delete                => 'delete',
            delete_curried        => [ delete => 1 ],
            insert                => 'insert',
            insert_curried        => [ insert => ( 1, 101 ) ],
            splice                => 'splice',
            splice_curried_1      => [ splice => 1 ],
            splice_curried_2      => [ splice => 1, 2 ],
            splice_curried_all    => [ splice => 1, 2, ( 3, 4, 5 ) ],
            sort                  => 'sort',
            sort_curried          => [ sort => ( sub { $_[1] <=> $_[0] } ) ],
            sort_in_place         => 'sort_in_place',
            sort_in_place_curried =>
                [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
            map                   => 'map',
            map_curried           => [ map => ( sub { $_ + 1 } ) ],
            grep                  => 'grep',
            grep_curried          => [ grep => ( sub { $_ < 5 } ) ],
            first                 => 'first',
            first_curried         => [ first => ( sub { $_ % 2 } ) ],
            join                  => 'join',
            join_curried          => [ join => '-' ],
            shuffle               => 'shuffle',
            uniq                  => 'uniq',
            reduce                => 'reduce',
            reduce_curried        => [ reduce => ( sub { $_[0] * $_[1] } ) ],
            natatime              => 'natatime',
            natatime_curried      => [ natatime => 2 ],
        },
        Hash    => {
            option_accessor  => 'accessor',
            quantity         => [ accessor => 'quantity' ],
            clear_options    => 'clear',
            num_options      => 'count',
            delete_option    => 'delete',
            is_defined       => 'defined',
            options_elements => 'elements',
            has_option       => 'exists',
            get_option       => 'get',
            has_no_options   => 'is_empty',
            keys             => 'keys',
            values           => 'values',
            key_value        => 'kv',
            set_option       => 'set',
        },
        Counter => {
            inc_counter    => 'inc',
            inc_counter_2  => [ inc => 2 ],
            dec_counter    => 'dec',
            dec_counter_2  => [ dec => 2 ],
            reset_counter  => 'reset',
            set_counter    => 'set',
            set_counter_42 => [ set => 42 ],
        },
        Number  => {
            abs         => 'abs',
            add         => 'add',
            inc         => [ add => 1 ],
            div         => 'div',
            cut_in_half => [ div => 2 ],
            mod         => 'mod',
            odd         => [ mod => 2 ],
            mul         => 'mul',
            set         => 'set',
            sub         => 'sub',
            dec         => [ sub => 1 ],
        },
        Bool    => {
            illuminate  => 'set',
            darken      => 'unset',
            flip_switch => 'toggle',
            is_dark     => 'not',
        },
        String  => {
            inc              => 'inc',
            append           => 'append',
            append_curried   => [ append => '!' ],
            prepend          => 'prepend',
            prepend_curried  => [ prepend => '-' ],
            replace          => 'replace',
            replace_curried  => [ replace => qr/(.)$/, sub { uc $1 } ],
            chop             => 'chop',
            chomp            => 'chomp',
            clear            => 'clear',
            match            => 'match',
            match_curried    => [ match  => qr/\D/ ],
            length           => 'length',
            substr           => 'substr',
            substr_curried_1 => [ substr => (1) ],
            substr_curried_2 => [ substr => ( 1, 3 ) ],
            substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
        },
        Code    => {
            execute        => 'execute',
            execute_method => 'execute_method',
        },
    );

    my %isa = (
        Array   => 'ArrayRef[Str]',
        Hash    => 'HashRef[Int]',
        Counter => 'Int',
        Number  => 'Num',
        Bool    => 'Bool',
        String  => 'Str',
        Code    => 'CodeRef',
    );

    my %default = (
        Array   => [],
        Hash    => {},
        Counter => 0,
        Number  => 0.0,
        Bool    => 1,
        String  => '',
        Code    => sub { },
    );

    for my $trait (keys %default) {
        my $class_name = "Native::$trait";
        my $handles = $handles{$trait};
        my $attr_class = Moose::Util::with_traits(
            'Moose::Meta::Attribute',
            "Moose::Meta::Attribute::Native::Trait::$trait",
        );
        Moose::Meta::Class->create(
            $class_name,
            superclasses => ['Moose::Object'],
            attributes   => [
                $attr_class->new(
                    'nonlazy',
                    is      => 'ro',
                    isa     => $isa{$trait},
                    default => sub { $default{$trait} },
                    handles => {
                        map {; "nonlazy_$_" => $handles->{$_} } keys %$handles
                    },
                ),
                $attr_class->new(
                    'lazy',
                    is      => 'ro',
                    isa     => $isa{$trait},
                    lazy    => 1,
                    default => sub { $default{$trait} },
                    handles => {
                        map {; "lazy_$_" => $handles->{$_} } keys %$handles
                    },
                ),
            ],
        );
        close_over_ok($class_name, $_) for (
            'new',
            map {; "nonlazy_$_", "lazy_$_" } keys %$handles
        );
    }
}

{
    package WithInitializer;
    use Moose;

    has foo => (
        is          => 'ro',
        isa         => 'Str',
        initializer => sub { },
    );

    has bar => (
        is          => 'ro',
        isa         => 'Str',
        lazy        => 1,
        default     => sub { 'a' },
        initializer => sub { },
    );

    __PACKAGE__->meta->make_immutable;
}

close_over_ok('WithInitializer', 'foo');
{ local $TODO = "initializer still closes over things";
close_over_ok('WithInitializer', $_) for qw(new bar);
}

BEGIN {
    package CustomErrorClass;
    use Moose;
    extends 'Moose::Error::Default';
}

{
    package WithCustomErrorClass;
    use metaclass (
        metaclass => 'Moose::Meta::Class',
        error_class => 'CustomErrorClass',
    );
    use Moose;

    has foo => (
        is  => 'ro',
        isa => 'Str',
    );

    __PACKAGE__->meta->make_immutable;
}

{ local $TODO = "custom error classes still close over things";
close_over_ok('WithCustomErrorClass', $_) for qw(new foo);
}

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