[SCM] libtype-tiny-perl Debian packaging branch, master, updated. debian/0.016-1-48-ga7f6748

[Toby Inkster]

The following commit has been merged in the master branch:
commit 3dedb0ceb1b6b2cf25422b00d4348d0ce678531c
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date:   Fri Jul 19 07:55:09 2013 +0100

    lexical sub support, cribbed from Eval::Closure

diff --git a/lib/Eval/TypeTiny.pm b/lib/Eval/TypeTiny.pm
index fa6139a..2ee3623 100644
--- a/lib/Eval/TypeTiny.pm
+++ b/lib/Eval/TypeTiny.pm
@@ -2,6 +2,8 @@ package Eval::TypeTiny;
 
 use strict;
 
+BEGIN { *HAS_LEXICAL_SUBS = ($] >= 5.018) ? sub(){!!1} : sub(){!!0} };
+
 sub _clean_eval
 {
 	local $@;
@@ -14,6 +16,7 @@ sub _clean_eval
 our $AUTHORITY = 'cpan:TOBYINK';
 our $VERSION   = '0.016';
 our @EXPORT    = qw( eval_closure );
+our @EXPORT_OK = qw( HAS_LEXICAL_SUBS );
 
 sub import
 {
@@ -56,7 +59,12 @@ sub eval_closure
 	my $source    = join "\n" => (
 		"package Eval::TypeTiny::Sandbox$sandbox;",
 		"sub {",
-		map(sprintf('my %s = %s{$_[%d]};', $_, substr($_, 0, 1), $i++), @keys),
+		map(
+			HAS_LEXICAL_SUBS
+				? _make_lexical_assignment($_, $i++)
+				: sprintf('my %s = %s{$_[%d]};', $_, substr($_, 0, 1), $i++),
+			@keys
+		),
 		$src,
 		"}",
 	);
@@ -76,6 +84,25 @@ sub eval_closure
 	return $compiler->(@{$args{environment}}{@keys});
 }
 
+HAS_LEXICAL_SUBS and eval <<'SUPPORT_LEXICAL_SUBS';
+my $tmp;
+sub _make_lexical_assignment
+{
+	my ($key, $index) = @_;
+	if (HAS_LEXICAL_SUBS and $key =~ /^\&/) {
+		$tmp++;
+		my $tmpname = '$__LEXICAL_SUB__'.$tmp;
+		my $name    = substr($key, 1);
+		return
+			"no warnings 'experimental::lexical_subs';".
+			"use feature 'lexical_subs';".
+			"my $tmpname = \$_[$index];".
+			"my sub $name { goto $tmpname };";
+	}
+	sprintf('my %s = %s{$_[%d]};', $key, substr($key, 0, 1), $index);
+}
+SUPPORT_LEXICAL_SUBS
+
 1;
 
 __END__
@@ -94,8 +121,10 @@ Eval::TypeTiny - utility to evaluate a string of Perl code in a clean environmen
 
 This is not considered part of Type::Tiny's public API.
 
-It exports one function, which works much like the similarly named function
-from L<Eval::Closure>:
+=head2 Functions
+
+This module exports one function, which works much like the similarly named
+function from L<Eval::Closure>:
 
 =over
 
@@ -103,6 +132,19 @@ from L<Eval::Closure>:
 
 =back
 
+=head2 Constants
+
+The following constant may be exported, but is not exported by default.
+
+=over
+
+=item C<< HAS_LEXICAL_SUBS >>
+
+Boolean indicating whether Eval::TypeTiny has support for lexical subs.
+(This feature requires Perl 5.18.)
+
+=back
+
 =head1 EVALUATION ENVIRONMENT
 
 The evaluation is performed in the presence of L<strict>, but the absence of
diff --git a/t/eval.t b/t/eval-lexicalsubs.t
similarity index 73%
copy from t/eval.t
copy to t/eval-lexicalsubs.t
index 9789d7e..edd6b01 100644
--- a/t/eval.t
+++ b/t/eval-lexicalsubs.t
@@ -4,7 +4,7 @@
 
 =head1 PURPOSE
 
-Tests L<Eval::TypeTiny>.
+Tests L<Eval::TypeTiny> with experimental lexical subs.
 
 =head1 AUTHOR
 
@@ -24,14 +24,18 @@ 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" },
+	'$foo'   => do { my $x = "foo"; \$x },
+	'@bar'   => [ "bar" ],
+	'%baz'   => { "baz" => "1" },
+	'&quux'  => sub { $variable },
+	'&quuux' => sub { $variable + 40 },
 );
 
 my $source = <<'SRC';
@@ -39,6 +43,8 @@ sub {
 	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
@@ -63,6 +69,26 @@ is_deeply(
 	'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(

-- 
libtype-tiny-perl Debian packaging