=pod

=encoding utf-8

=head1 PURPOSE

Various tests of named and anonymous functions closing over variables.

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013-2014 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

use strict;
use warnings;
use Test::More;
use Test::Fatal;

my $x;
BEGIN { $x = 1 };

package Foo {
	use Kavorka;
	method new ($class: ...) {
		bless {}, $class;
	}
	method inc { ++$x }
	method dec { --$x }
}

subtest "Two functions closing over the same variable" => sub
{
	my $foo = Foo->new;
	
	is($x, 1);
	is($foo->inc, 2);
	is($foo->inc, 3);
	is($x, 3);
	is($foo->dec, 2);
	is($foo->dec, 1);
	is($x, 1);
};

package Goo {
	use Kavorka;
	
	method xyz {
		my @links;
		fun my $xxx { push @links, 42 };
		$xxx->();
		return \@links;
	}
}

subtest "Closing over a variable in a lexical function" => sub
{
	is_deeply(Goo->xyz, [42]);
	is_deeply(Goo->xyz, [42]);
	is_deeply(Goo->xyz, [42]);
};

package Hoo {
	use Kavorka;
	method xyz ($closeme) {
		my $f = fun ($vvv = $closeme) { $vvv };
		return (\$closeme, $f);
	}
}

subtest "Closing over a variable in a default" => sub
{
	my ($X1, $fourtytwo) = Hoo->xyz(42);
	is($fourtytwo->(666), 666);
	is($fourtytwo->(), 42);
	
	my ($X2, $sixsixsix) = Hoo->xyz(666);
	is($sixsixsix->(999), 999);
	is($sixsixsix->(), 666);
	$$X2 = 777;
	is($sixsixsix->(), 777);
};

package Ioo {
	use Kavorka;
	method get_limit ($limit) {
		fun (Int $x where { $_ < $limit }) { 1 };
	}
}

subtest "Closing over a variable in a where {} block" => sub
{
	my $lim7 = Ioo->get_limit(7);
	ok $lim7->(6);
	ok exception { $lim7->(8) };
	
	my $lim12 = Ioo->get_limit(12);
	ok $lim12->(8);
	ok exception { $lim12->(14) };
	
	ok $lim7->(6);
	ok exception { $lim7->(8) };
};

package Joo {
	use Kavorka;
	method get_set ($x) {
		return (
			fun ()   { $x },
			fun ($y) { $x = $y },
		);
	}
}

subtest "Two anonymous functions closing over the same variable" => sub
{
	my ($g, $s) = Joo->get_set(20);
	my ($g2, $s2) = Joo->get_set(666);
	is($g->(), 20);
	is($s->(21), 21);
	is($g->(), 21);
	is($s->($g->() * 2), 42);
	is($g->(), 42);
	is($g2->(), 666);
};

done_testing;