Eval-Closure-0.13HEADEval-Closure-0.13master

11 files changed, 542 insertions, 0 deletions

diff --git a/t/00-compile.t b/t/00-compile.t
new file mode 100644
index 0000000..58d98f8
--- /dev/null
+++ b/t/00-compile.t
@@ -0,0 +1,50 @@
+use 5.006;
+use strict;
+use warnings;
+
+# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.043
+
+use Test::More  tests => 1 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
+
+
+
+my @module_files = (
+    'Eval/Closure.pm'
+);
+
+
+
+# no fake home requested
+
+my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib';
+
+use File::Spec;
+use IPC::Open3;
+use IO::Handle;
+
+open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!";
+
+my @warnings;
+for my $lib (@module_files)
+{
+    # see L<perlfaq8/How can I capture STDERR from an external command?>
+    my $stderr = IO::Handle->new;
+
+    my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]");
+    binmode $stderr, ':crlf' if $^O eq 'MSWin32';
+    my @_warnings = <$stderr>;
+    waitpid($pid, 0);
+    is($?, 0, "$lib loaded ok");
+
+    if (@_warnings)
+    {
+        warn @_warnings;
+        push @warnings, @_warnings;
+    }
+}
+
+
+
+is(scalar(@warnings), 0, 'no warnings found') if $ENV{AUTHOR_TESTING};
+
+
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..3a318ac
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,48 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+use Eval::Closure;
+
+{
+    my $code = eval_closure(
+        source => 'sub { die "called\n" }',
+    );
+    ok($code, "got something");
+
+    like(exception { $code->() }, qr/^called$/, "got the right thing");
+}
+
+{
+    my $foo = [];
+
+    my $code = eval_closure(
+        source      => 'sub { push @$bar, @_ }',
+        environment => {
+            '$bar' => \$foo,
+        },
+    );
+    ok($code, "got something");
+
+    $code->(1);
+
+    is_deeply($foo, [1], "got the right thing");
+}
+
+{
+    my $foo = [1, 2, 3];
+
+    my $code = eval_closure(
+        # not sure if strict leaking into evals is intended, i think i remember
+        # it being changed in newer perls
+        source => 'do { no strict; sub { $foo } }',
+    );
+
+    ok($code, "got something");
+
+    ok(!$code->(), "environment is clean");
+}
+
+done_testing;
diff --git a/t/canonicalize-source.t b/t/canonicalize-source.t
new file mode 100644
index 0000000..79c08a3
--- /dev/null
+++ b/t/canonicalize-source.t
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Eval::Closure;
+
+{
+    my $code = eval_closure(
+        source =>
+            'sub {'
+          .     '"foo"'
+          . '}',
+    );
+    ok($code, "got code");
+    is($code->(), "foo", "got the right code");
+}
+
+{
+    my $code = eval_closure(
+        source => [
+            'sub {',
+                '"foo"',
+            '}',
+        ],
+    );
+    ok($code, "got code");
+    is($code->(), "foo", "got the right code");
+}
+
+done_testing;
diff --git a/t/close-over-nonref.t b/t/close-over-nonref.t
new file mode 100644
index 0000000..62096c3
--- /dev/null
+++ b/t/close-over-nonref.t
@@ -0,0 +1,20 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires { "Devel::LexAlias" => "0.05" };
+
+use Eval::Closure;
+
+my $number  = 40;
+my $closure = eval_closure(
+    source       => 'sub { $xxx += 2 }',
+    environment  => { '$xxx' => \$number },
+    alias        => 1,
+);
+
+$closure->();
+
+is($number, 42);
+
+done_testing;
diff --git a/t/close-over.t b/t/close-over.t
new file mode 100644
index 0000000..905a3f7
--- /dev/null
+++ b/t/close-over.t
@@ -0,0 +1,72 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+use B;
+use Eval::Closure;
+
+use Test::Requires 'PadWalker';
+
+{
+    my $foo = [];
+    my $env = { '$foo' => \$foo };
+
+    my $code = eval_closure(
+        source      => 'sub { push @$foo, @_ }',
+        environment => $env,
+    );
+    is_deeply(scalar(PadWalker::closed_over($code)), $env,
+              "closed over the right things");
+}
+
+{
+    my $foo = {};
+    my $bar = [];
+    my $env = { '$foo' => \$bar, '$bar' => \$foo };
+
+    my $code = eval_closure(
+        source      => 'sub { push @$foo, @_; $bar->{foo} = \@_ }',
+        environment => $env,
+    );
+    is_deeply(scalar(PadWalker::closed_over($code)), $env,
+              "closed over the right things");
+}
+
+{
+    # i feel dirty
+    my $c = eval_closure(source => 'sub { }');
+    my $b = B::svref_2object($c);
+    my @scopes;
+    while ($b->isa('B::CV')) {
+        push @scopes, $b;
+        $b = $b->OUTSIDE;
+    }
+    my @visible_in_outer_scope
+        = grep { defined && length && $_ ne '&' }
+          map  { $_->PV }
+          grep { $_->can('PV') }
+          map  { $_->PADLIST->ARRAYelt(0)->ARRAY }
+          @scopes;
+
+    # test to ensure we don't inadvertently screw up this test by rearranging
+    # code. if the scope that encloses the eval ends up not declaring $e, then
+    # change this test.
+    ok(scalar(grep { $_ eq '$e' } @visible_in_outer_scope),
+       "visible list is sane");
+
+    for my $outer_scope_pad_entry (@visible_in_outer_scope) {
+        like(
+            exception {
+                eval_closure(
+                    source => "sub { $outer_scope_pad_entry }",
+                );
+            },
+            qr/Global symbol "\Q$outer_scope_pad_entry/,
+            "we don't close over $outer_scope_pad_entry"
+        );
+    }
+}
+
+done_testing;
diff --git a/t/compiling-package.t b/t/compiling-package.t
new file mode 100644
index 0000000..fa27d0e
--- /dev/null
+++ b/t/compiling-package.t
@@ -0,0 +1,44 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Eval::Closure;
+
+{
+    my $code = eval_closure(
+        source => 'no strict "refs"; sub { keys %{__PACKAGE__ . "::"} }',
+    );
+
+    # defining the sub { } creates __ANON__, calling 'no strict' creates BEGIN
+    my @stash_keys = grep { $_ ne '__ANON__' && $_ ne 'BEGIN' } $code->();
+
+    is_deeply([@stash_keys], [], "compiled in an empty package");
+}
+
+{
+    # the more common case where you'd run into this is imported subs
+    # for instance, Bread::Board::as vs Moose::Util::TypeConstraints::as
+    my $c1 = eval_closure(
+        source => 'no strict "vars"; sub { ++$foo }',
+    );
+    my $c2 = eval_closure(
+        source => 'no strict "vars"; sub { --$foo }',
+    );
+    is($c1->(), 1);
+    is($c1->(), 2);
+    is($c2->(), -1);
+    is($c2->(), -2);
+}
+
+{
+    my $source = 'no strict "vars"; sub { ++$foo }';
+    my $c1 = eval_closure(source => $source);
+    my $c2 = eval_closure(source => $source);
+    is($c1->(), 1);
+    is($c1->(), 2);
+    is($c2->(), 1);
+    is($c2->(), 2);
+}
+
+done_testing;
diff --git a/t/debugger.t b/t/debugger.t
new file mode 100644
index 0000000..7b97272
--- /dev/null
+++ b/t/debugger.t
@@ -0,0 +1,23 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE
+
+use Eval::Closure;
+
+unlike(
+    exception {
+        eval_closure(
+            source      => 'sub { $bar }',
+            description => 'foo',
+        )
+    },
+    qr/#line/,
+    "#line directive isn't added when debugger is active"
+);
+
+
+done_testing;
diff --git a/t/description.t b/t/description.t
new file mode 100644
index 0000000..269b530
--- /dev/null
+++ b/t/description.t
@@ -0,0 +1,53 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+use Eval::Closure;
+
+my $source = <<'SOURCE';
+sub {
+    Carp::confess("foo")
+}
+SOURCE
+
+{
+    my $code = eval_closure(
+        source => $source,
+    );
+
+    like(
+        exception { $code->() },
+        qr/^foo at \(eval \d+\) line \d+/,
+        "no location info if context isn't passed"
+    );
+}
+
+{
+    my $code = eval_closure(
+        source      => $source,
+        description => 'accessor foo (defined at Class.pm line 282)',
+    );
+
+    like(
+        exception { $code->() },
+        qr/^foo at accessor foo \(defined at Class\.pm line 282\) line 2/,
+        "description is set"
+    );
+}
+
+{
+    my $code = eval_closure(
+        source      => $source,
+        line        => 100,
+        description => 'accessor foo (defined at Class.pm line 282)',
+    );
+
+    like(
+        exception { $code->() },
+        qr/^foo at accessor foo \(defined at Class\.pm line 282\) line 101/,
+        "description is set"
+    );
+}
+done_testing;
diff --git a/t/errors.t b/t/errors.t
new file mode 100644
index 0000000..3f0cde2
--- /dev/null
+++ b/t/errors.t
@@ -0,0 +1,67 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+use Eval::Closure;
+
+like(
+    exception { eval_closure() },
+    qr/'source'.*required/,
+    "error when source isn't declared"
+);
+
+like(
+    exception { eval_closure(source => {}) },
+    qr/'source'.*string or array/,
+    "error when source isn't string or array"
+);
+
+like(
+    exception { eval_closure(source => 1) },
+    qr/'source'.*return.*sub/,
+    "error when source doesn't return a sub"
+);
+
+like(
+    exception {
+        eval_closure(
+            source      => 'sub { }',
+            environment => { 'foo' => \1 },
+        )
+    },
+    qr/should start with \@, \%,/,
+    "error from malformed env"
+);
+
+like(
+    exception {
+        eval_closure(
+            source      => 'sub { }',
+            environment => { '$foo' => 1 },
+        )
+    },
+    qr/must be.*reference/,
+    "error from non-ref value"
+);
+
+like(
+    exception { eval_closure(source => '$1++') },
+    qr/Modification of a read-only value/,
+    "gives us compile errors properly"
+);
+
+like(
+    exception { eval_closure(source => 'sub { $x }') },
+    qr/sub \s* { \s* \$x \s* }/x,
+    "without terse_error, includes the source code"
+);
+
+unlike(
+    exception { eval_closure(source => 'sub { $x }', terse_error => 1) },
+    qr/sub \s* { \s* \$x \s* }/x,
+    "with terse_error, does not include the source code"
+);
+
+done_testing;
diff --git a/t/lexical-subs.t b/t/lexical-subs.t
new file mode 100644
index 0000000..db425c9
--- /dev/null
+++ b/t/lexical-subs.t
@@ -0,0 +1,26 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+    if (!eval { require 5.018; 1 }) {
+        plan skip_all => "this test requires 5.18";
+    }
+}
+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;
diff --git a/t/memoize.t b/t/memoize.t
new file mode 100644
index 0000000..b012596
--- /dev/null
+++ b/t/memoize.t
@@ -0,0 +1,108 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+use Test::Requires 'Test::Output';
+
+use Eval::Closure;
+
+# XXX this whole test isn't very useful anymore, since we no longer do
+# memoization. it would be nice to bring it back at some point though, if there
+# was a way to do this without breaking the other tests
+
+plan skip_all => "disabling this test for now";
+
+{
+    my $source = 'BEGIN { warn "foo\n" } sub { $foo * 2 }';
+
+    my $code;
+    my $bar = 15;
+    stderr_is {
+        $code = eval_closure(
+            source      => $source,
+            environment => {
+                '$foo' => \$bar,
+            },
+        );
+    } "foo\n", "BEGIN was run";
+
+    is($code->(), 30, "got the right sub");
+
+    my $code2;
+    my $baz = 8;
+    stderr_is {
+        $code2 = eval_closure(
+            source      => $source,
+            environment => {
+                '$foo' => \$baz,
+            },
+        );
+    } '', "BEGIN was not run twice";
+
+    is($code2->(), 16, "got the right sub");
+}
+
+{
+    my $source = 'BEGIN { warn "bar\n" } sub { $bar * 2 }';
+
+    my $code;
+    my $foo = 60;
+    stderr_is {
+        $code = eval_closure(
+            source      => $source,
+            environment => {
+                '$bar' => \$foo,
+            },
+            description => 'foo',
+        );
+    } "bar\n", "BEGIN was run";
+
+    is($code->(), 120, "got the right sub");
+
+    my $code2;
+    my $baz = 23;
+    { local $TODO = "description breaks memoization";
+    stderr_is {
+        $code2 = eval_closure(
+            source      => $source,
+            environment => {
+                '$bar' => \$baz,
+            },
+            description => 'baz',
+        );
+    } '', "BEGIN was not run twice";
+    }
+
+    is($code2->(), 46, "got the right sub");
+}
+
+{
+    my $source = 'BEGIN { warn "baz\n" } sub { Carp::confess "baz" }';
+
+    my $code;
+    stderr_is {
+        $code = eval_closure(
+            source      => $source,
+            description => 'first',
+        );
+    } "baz\n", "BEGIN was run";
+
+    like(exception { $code->() }, qr/baz at first line 1/,
+         "got the right description");
+
+    my $code2;
+    { local $TODO = "description breaks memoization";
+    stderr_is {
+        $code2 = eval_closure(
+            source      => $source,
+            description => 'second',
+        );
+    } '', "BEGIN was not run twice";
+    }
+
+    like(exception { $code2->() }, qr/baz at second line 1/,
+         "got the right description");
+}
+
+done_testing;