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
|
package Eval::Closure;
use Sub::Exporter -setup => {
exports => [qw(eval_closure)],
};
use Carp;
use overload ();
use Scalar::Util qw(reftype);
use Try::Tiny;
sub eval_closure {
my (%args) = @_;
$args{source} = _canonicalize_source($args{source});
my ($code, $e) = _clean_eval_closure(@args{qw(source environment name)});
croak("Failed to compile source: $e\n\nsource:\n$args{source}")
unless $code;
return $code;
}
sub _canonicalize_source {
my ($source) = @_;
if (defined($source)) {
if (ref($source)) {
if (reftype($source) eq 'ARRAY'
|| overload::Method($source, '@{}')) {
return join "\n", @$source;
}
elsif (overload::Method($source, '""')) {
return "$source";
}
else {
croak("The 'source' parameter to eval_closure must be a "
. "string or array reference");
}
}
else {
return $source;
}
}
else {
croak("The 'source' parameter to eval_closure is required");
}
}
sub _clean_eval_closure {
# my ($source, $__captures, $name) = @_
my $__captures = $_[1];
do {
local $@;
local $SIG{__DIE__};
if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) {
_dump_source(_make_source(@_), $_[2]);
}
my $code = eval _make_source(@_);
($code, $@);
};
}
sub _make_source {
my ($source, $__captures) = @_;
return join "\n", (
(map {
die "Capture key should start with \@, \% or \$: $_"
unless /^([\@\%\$])/;
'my ' . $_ . ' = ' . $1 . '{$__captures->{\'' . $_ . '\'}};';
} keys %$__captures),
$source,
);
}
sub _dump_source {
my ($source, $name) = @_;
my $output;
if (try { require Perl::Tidy }) {
Perl::Tidy::perltidy(
source => \$source,
destination => \$output,
);
}
else {
$output = $source;
}
$name = defined($name) ? $name : "__ANON__";
warn $name . ":\n" . $output . "\n";
}
1;
|