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 <m...@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>toby...@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
_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
