[libtype-tiny-perl] 02/27: Eval::TypeTiny should support alias=>0|1 like Eval::Closure hopefully will

[Jonas Smedegaard]

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

js pushed a commit to branch master
in repository libtype-tiny-perl.

commit 2943b957dff7ff535f60cc05f36fe6fdb94b72ae
Author: Toby Inkster <mail at tobyinkster.co.uk>
Date:   Tue Jul 30 10:14:36 2013 +0100

    Eval::TypeTiny should support alias=>0|1 like Eval::Closure hopefully will
---
 lib/Eval/TypeTiny.pm |   35 ++++++++++++++++++++++++++---------
 t/eval.t             |    4 ++++
 2 files changed, 30 insertions(+), 9 deletions(-)

diff --git a/lib/Eval/TypeTiny.pm b/lib/Eval/TypeTiny.pm
index 69b51f3..9dd8371 100644
--- a/lib/Eval/TypeTiny.pm
+++ b/lib/Eval/TypeTiny.pm
@@ -3,10 +3,17 @@ package Eval::TypeTiny;
 use strict;
 
 BEGIN {
-	*HAS_LEXICAL_SUBS = ($] >= 5.018)                    ? sub(){!!1} : sub(){!!0};
-	*HAS_LEXICAL_VARS = eval { require Devel::LexAlias } ? sub(){!!1} : sub(){!!0};
+	*HAS_LEXICAL_SUBS = ($] >= 5.018) ? sub(){!!1} : sub(){!!0};
 };
 
+{
+	my $hlv;
+	sub HAS_LEXICAL_VARS () {
+		$hlv = !! eval { require Devel::LexAlias } unless defined $hlv;
+		return $hlv;
+	}
+}
+
 sub _clean_eval
 {
 	local $@;
@@ -42,6 +49,7 @@ sub eval_closure
 	my (%args) = @_;
 	my $src    = ref $args{source} eq "ARRAY" ? join("\n", @{$args{source}}) : $args{source};
 	
+	$args{alias}  = 0 unless defined $args{alias};
 	$args{line}   = 1 unless defined $args{line};
 	$args{description} =~ s/[^\w .:-\[\]\(\)\{\}\']//g if defined $args{description};
 	$src = qq{#line $args{line} "$args{description}"\n$src} if defined $args{description} && !($^P & 0x10);
@@ -57,16 +65,19 @@ sub eval_closure
 #		Type::Exception::croak("Expected a variable name and ref; got %s => %s", $k, $args{environment}{$k});
 #	}
 	
+	my $alias     = exists($args{alias}) ? $args{alias} : 0;
 	my @keys      = sort keys %{$args{environment}};
 	my $i         = 0;
 	my $source    = join "\n" => (
 		"package Eval::TypeTiny::Sandbox$sandbox;",
 		"sub {",
-		map(_make_lexical_assignment($_, $i++), @keys),
+		map(_make_lexical_assignment($_, $i++, $alias), @keys),
 		$src,
 		"}",
 	);
 	
+	_manufacture_ties() if $alias && !HAS_LEXICAL_VARS;
+	
 	my ($compiler, $e) = _clean_eval($source);
 	if ($e)
 	{
@@ -81,8 +92,7 @@ sub eval_closure
 	
 	my $code = $compiler->(@{$args{environment}}{@keys});
 
-	if (HAS_LEXICAL_VARS)
-	{
+	if ($alias && HAS_LEXICAL_VARS) {
 		Devel::LexAlias::lexalias($code, $_, $args{environment}{$_}) for grep !/^\&/, @keys;
 	}
 	
@@ -92,7 +102,7 @@ sub eval_closure
 my $tmp;
 sub _make_lexical_assignment
 {
-	my ($key, $index) = @_;
+	my ($key, $index, $alias) = @_;
 	my $name = substr($key, 1);
 	
 	if (HAS_LEXICAL_SUBS and $key =~ /^\&/) {
@@ -105,7 +115,11 @@ sub _make_lexical_assignment
 			"my sub $name { goto $tmpname };";
 	}
 	
-	if (HAS_LEXICAL_VARS) {
+	if (!$alias) {
+		my $sigil = substr($key, 0, 1);
+		return "my $key = $sigil\{ \$_[$index] };";
+	}
+	elsif (HAS_LEXICAL_VARS) {
 		return "my $key;";
 	}
 	else {
@@ -124,7 +138,7 @@ sub _make_lexical_assignment
 	}
 }
 
-HAS_LEXICAL_VARS or eval <<'FALLBACK';
+{ my $tie; sub _manufacture_ties { $tie ||= eval <<'FALLBACK'; } }
 no warnings qw(void once uninitialized numeric);
 
 {
@@ -214,6 +228,8 @@ no warnings qw(void once uninitialized numeric);
 		fallback => 1,
 	;
 }
+
+1;
 FALLBACK
 
 1;
@@ -261,7 +277,8 @@ Boolean indicating whether Eval::TypeTiny has support for lexical subs.
 Don't worry; closing over lexical variables in the closures is always
 supported! However, if this constant is true, it means that
 L<Devel::LexAlias> is available, which makes them slightly faster than
-the fallback solution which uses tied variables.
+the fallback solution which uses tied variables. (This only makes any
+difference when the C<< alias => 1 >> option is used.)
 
 =back
 
diff --git a/t/eval.t b/t/eval.t
index ef10af0..9d0eb27 100644
--- a/t/eval.t
+++ b/t/eval.t
@@ -67,6 +67,7 @@ my $external = 40;
 my $closure2 = eval_closure(
 	source      => 'sub { $xxx += 2 }',
 	environment => { '$xxx' => \$external },
+	alias       => 1,
 );
 
 $closure2->();
@@ -86,6 +87,7 @@ is($external, 42, 'closing over variables really really really works!');
 		my $closure = eval_closure(
 			source       => 'sub { $$xxx += 2 }',
 			environment  => { '$xxx' => \$number },
+			alias        => 1,
 		);
 		
 		$closure->();
@@ -119,6 +121,7 @@ is($external, 42, 'closing over variables really really really works!');
 	my $closure = eval_closure(
 		source       => 'sub { $xxx = $_[0]; tied($xxx)->my_method }',
 		environment  => { '$xxx' => \$var },
+		alias        => 1,
 	);
 	
 	is($closure->(2), 42, 'can close over tied variables ... AUTOLOAD stuff');
@@ -127,6 +130,7 @@ is($external, 42, 'closing over variables really really really works!');
 	my $nother_closure = eval_closure(
 		source       => 'sub { tied($xxx)->can(@_) }',
 		environment  => { '$xxx' => \$var },
+		alias        => 1,
 	);
 	
 	ok( $nother_closure->('my_method'), '... can');

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