1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
|
=pod
=encoding utf-8
=head1 PURPOSE
Tests L<Eval::TypeTiny> with experimental lexical subs.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2013-2014, 2017-2023 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;
use Test::Requires 'v5.18';
use Test::Fatal;
use Eval::TypeTiny;
my $variable;
my %env = (
'$foo' => do { my $x = "foo"; \$x },
'@bar' => [ "bar" ],
'%baz' => { "baz" => "1" },
'&quux' => sub { $variable },
'&quuux' => sub { $variable + 40 },
);
my $source = <<'SRC';
sub {
package Kill::La::NonLexikill;
return $foo if $_[0] eq '$foo';
return @bar if $_[0] eq '@bar';
return %baz if $_[0] eq '%baz';
return quux() if $_[0] eq '&quux';
return quuux if $_[0] eq '&quuux';
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',
);
is_deeply(
[ $closure->('&quux') ],
[ undef ],
'closure over lexical sub - undef',
);
$variable = 2;
is_deeply(
[ $closure->('&quux') ],
[ 2 ],
'closure over lexical sub - 2',
);
is_deeply(
[ $closure->('&quuux') ],
[ 42 ],
'closure over lexical sub - 42',
);
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;
|