From: Jesse Luehrs <doy@tozt.net>
Date: Wed, 10 Jul 2013 22:17:03 +0000 (-0400)
Subject: support lexical subs with the '&' sigil
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a55b2a20f72b216066b59557846f9fec06dbf984;p=gitmo%2FEval-Closure.git

support lexical subs with the '&' sigil
---

diff --git a/lib/Eval/Closure.pm b/lib/Eval/Closure.pm
index 161bcdf..3a5a2cf 100644
--- a/lib/Eval/Closure.pm
+++ b/lib/Eval/Closure.pm
@@ -12,6 +12,8 @@ use overload ();
 use Scalar::Util qw(reftype);
 use Try::Tiny;
 
+use constant HAS_LEXICAL_SUBS => $] >= 5.018;
+
 =head1 SYNOPSIS
 
   use Eval::Closure;
@@ -69,6 +71,11 @@ would allow the generated function to use an array named C<@foo>). Generally,
 this is used to allow the generated function to access externally defined
 variables (so you would pass in a reference to a variable that already exists).
 
+In perl 5.18 and greater, the environment hash can contain variables with a
+sigil of C<&>. This will create a lexical sub in the evaluated code (see
+L<feature/The 'lexical_subs' feature>). Using a C<&> sigil on perl versions
+before lexical subs were available will throw an error.
+
 =item description
 
 This lets you provide a bit more information in backtraces. Normally, when a
@@ -151,8 +158,14 @@ sub _validate_env {
         unless reftype($env) eq 'HASH';
 
     for my $var (keys %$env) {
-        croak("Environment key '$var' should start with \@, \%, or \$")
-            unless $var =~ /^([\@\%\$])/;
+        if (HAS_LEXICAL_SUBS) {
+            croak("Environment key '$var' should start with \@, \%, \$, or \&")
+                unless $var =~ /^([\@\%\$\&])/;
+        }
+        else {
+            croak("Environment key '$var' should start with \@, \%, or \$")
+                unless $var =~ /^([\@\%\$])/;
+        }
         croak("Environment values must be references, not $env->{$var}")
             unless ref($env->{$var});
     }
@@ -213,14 +226,28 @@ sub _make_compiler_source {
     return join "\n", (
         "package Eval::Closure::Sandbox_$Eval::Closure::SANDBOX_ID;",
         'sub {',
-        (map {
-            'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};'
-         } @capture_keys),
-        $source,
+            (map { _make_lexical_assignment($_, $i++) } @capture_keys),
+            $source,
         '}',
     );
 }
 
+sub _make_lexical_assignment {
+    my ($key, $index) = @_;
+    my $sigil = substr($key, 0, 1);
+    my $name = substr($key, 1);
+    if (HAS_LEXICAL_SUBS && $sigil eq '&') {
+        my $tmpname = '$__' . $name . '__' . $index;
+        return 'use feature "lexical_subs"; '
+             . 'no warnings "experimental::lexical_subs"; '
+             . 'my ' . $tmpname . ' = $_[' . $index . ']; '
+             . 'my sub ' . $name . ' { goto ' . $tmpname . ' }';
+    }
+    else {
+        return 'my ' . $key . ' = ' . $sigil . '{$_[' . $index . ']};';
+    }
+}
+
 sub _dump_source {
     my ($source) = @_;
 
diff --git a/t/errors.t b/t/errors.t
index 905d6c8..3f0cde2 100644
--- a/t/errors.t
+++ b/t/errors.t
@@ -31,7 +31,7 @@ like(
             environment => { 'foo' => \1 },
         )
     },
-    qr/should start with \@, \%, or \$/,
+    qr/should start with \@, \%,/,
     "error from malformed env"
 );
 
diff --git a/t/lexical-subs.t b/t/lexical-subs.t
new file mode 100644
index 0000000..dbcd178
--- /dev/null
+++ b/t/lexical-subs.t
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Test::Requires '5.018';
+use 5.018;
+
+use Eval::Closure;
+
+my $sub = eval_closure(
+    source => 'sub { foo() }',
+    environment => {
+        '&foo' => sub { state $i++ },
+    }
+);
+
+is($sub->(), 0);
+is($sub->(), 1);
+is($sub->(), 2);
+
+done_testing;