[libtype-tiny-perl] 13/14: need to get this working

[Jonas Smedegaard]

This is an automated email from the git hooks/post-receive script.

js pushed a commit to tag 0.043_03
in repository libtype-tiny-perl.

commit 096177bf4789010b8b293531131171299cf2720f
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date:   Tue May 6 21:37:13 2014 +0100

    need to get this working
---
 t/20-unit/Eval-TypeTiny/fallback-aliases.t | 212 +++++++++++++++++++++++++++++
 1 file changed, 212 insertions(+)

diff --git a/t/20-unit/Eval-TypeTiny/fallback-aliases.t b/t/20-unit/Eval-TypeTiny/fallback-aliases.t
new file mode 100644
index 0000000..1cc861a
--- /dev/null
+++ b/t/20-unit/Eval-TypeTiny/fallback-aliases.t
@@ -0,0 +1,212 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Tests L<Eval::TypeTiny> supports alias=>1 even when L<Devel::LexAlias>
+is unavailable.
+
+=head1 DEPENDENCIES
+
+Requires L<Test::Without::Module>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink at 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 lib qw( ./lib ./t/lib ../inc ./inc );
+
+use Test::More;
+
+BEGIN { plan skip_all => "test currently not working (TODO)" };
+
+use Test::Requires 'Test::Without::Module';
+use Test::Without::Module 'Devel::LexAlias';
+
+use Eval::TypeTiny;
+
+my %env = (
+	'$foo' => do { my $x = "foo"; \$x },
+	'@bar' => [ "bar" ],
+	'%baz' => { "baz" => "1" },
+);
+
+my $source = <<'SRC';
+sub {
+	return $foo if $_[0] eq '$foo';
+	return @bar if $_[0] eq '@bar';
+	return %baz if $_[0] eq '%baz';
+	return;
+}
+SRC
+
+my $closure = eval_closure(source => $source, environment => \%env);
+
+is_deeply(
+	[ $closure->('$foo') ],
+	[ 'foo' ],
+	'closure over scalar',
+);
+
+is_deeply(
+	[ $closure->('@bar') ],
+	[ 'bar' ],
+	'closure over array',
+);
+
+is_deeply(
+	[ $closure->('%baz') ],
+	[ 'baz' => 1 ],
+	'closure over hash',
+);
+
+my $external = 40;
+my $closure2 = eval_closure(
+	source      => 'sub { $xxx += 2 }',
+	environment => { '$xxx' => \$external },
+	alias       => 1,
+);
+
+$closure2->();
+is($external, 42, 'closing over variables really really really works!');
+
+{
+	my $destroyed = 0;
+	
+	{
+		package MyIndicator;
+		sub DESTROY { $destroyed++ }
+	}
+	
+	{
+		my $number = bless \(my $foo), "MyIndicator";
+		$$number = 40;
+		my $closure = eval_closure(
+			source       => 'sub { $$xxx += 2 }',
+			environment  => { '$xxx' => \$number },
+			alias        => 1,
+		);
+		
+		$closure->();
+		
+		is($$number, 42);
+		is($destroyed, 0);
+	}
+	
+	is($destroyed, 1, 'closed over variables disappear on cue');
+}
+
+{
+	my @store;
+	
+	{
+		package MyTie;
+		use Tie::Scalar ();
+		our @ISA = 'Tie::StdScalar';
+		sub STORE {
+			my $self = shift;
+			push @store, $_[0];
+			$self->SUPER::STORE(@_);
+		}
+		sub method_of_mine { 42 }
+	}
+	
+	tie(my($var), 'MyTie');
+	
+	$var = 1;
+	
+	my $closure = eval_closure(
+		source       => 'sub { $xxx = $_[0]; tied($xxx)->method_of_mine }',
+		environment  => { '$xxx' => \$var },
+		alias        => 1,
+	);
+	
+	is($closure->(2), 42, 'can close over tied variables ... AUTOLOAD stuff');
+	$closure->(3);
+	
+	my $nother_closure = eval_closure(
+		source       => 'sub { tied($xxx)->can(@_) }',
+		environment  => { '$xxx' => \$var },
+		alias        => 1,
+	);
+	
+	ok( $nother_closure->('method_of_mine'), '... can');
+	ok(!$nother_closure->('your_method'), '... !can');
+
+	is_deeply(
+		\@store,
+		[ 1 .. 3],
+		'... tie still works',
+	);
+
+	{
+		package OtherTie;
+		our @ISA = 'MyTie';
+		sub method_of_mine { 666 }
+	}
+	
+	tie($var, 'OtherTie');
+	is($closure->(4), 666, '... can be retied');
+
+	untie($var);
+	my $e = exception { $closure->(5) };
+	like($e, qr{^Can't call method "method_of_mine" on an undefined value}, '... can be untied');
+}
+
+my $e = exception { eval_closure(source => 'sub { 1 ]') };
+
+isa_ok(
+	$e,
+	'Error::TypeTiny::Compilation',
+	'$e',
+);
+
+like(
+	$e,
+	qr{^Failed to compile source because: syntax error},
+	'throw exception when code does not compile',
+);
+
+like(
+	$e->errstr,
+	qr{^syntax error},
+	'$e->errstr',
+);
+
+like(
+	$e->code,
+	qr{sub \{ 1 \]},
+	'$e->code',
+);
+
+my $c1 = eval_closure(source => 'sub { die("BANG") }', description => 'test1');
+my $e1 = exception { $c1->() };
+
+like(
+	$e1,
+	qr{^BANG at test1 line 1},
+	'"description" option works',
+);
+
+my $c2 = eval_closure(source => 'sub { die("BANG") }', description => 'test2', line => 222);
+my $e2 = exception { $c2->() };
+
+like(
+	$e2,
+	qr{^BANG at test2 line 222},
+	'"line" option works',
+);
+
+done_testing;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libtype-tiny-perl.git