Commit | Line | Data |
efb592ef |
1 | package Eval::Closure; |
2 | use Sub::Exporter -setup => { |
3 | exports => [qw(eval_closure)], |
ce19c70b |
4 | groups => { default => [qw(eval_closure)] }, |
efb592ef |
5 | }; |
6 | |
7 | use Carp; |
8 | use overload (); |
9 | use Scalar::Util qw(reftype); |
10 | use Try::Tiny; |
11 | |
12 | sub eval_closure { |
13 | my (%args) = @_; |
14 | $args{source} = _canonicalize_source($args{source}); |
15 | |
16 | my ($code, $e) = _clean_eval_closure(@args{qw(source environment name)}); |
17 | |
18 | croak("Failed to compile source: $e\n\nsource:\n$args{source}") |
19 | unless $code; |
20 | |
21 | return $code; |
22 | } |
23 | |
24 | sub _canonicalize_source { |
25 | my ($source) = @_; |
26 | |
27 | if (defined($source)) { |
28 | if (ref($source)) { |
29 | if (reftype($source) eq 'ARRAY' |
30 | || overload::Method($source, '@{}')) { |
31 | return join "\n", @$source; |
32 | } |
33 | elsif (overload::Method($source, '""')) { |
34 | return "$source"; |
35 | } |
36 | else { |
37 | croak("The 'source' parameter to eval_closure must be a " |
38 | . "string or array reference"); |
39 | } |
40 | } |
41 | else { |
42 | return $source; |
43 | } |
44 | } |
45 | else { |
46 | croak("The 'source' parameter to eval_closure is required"); |
47 | } |
48 | } |
49 | |
50 | sub _clean_eval_closure { |
d3319272 |
51 | # my ($source, $__captures, $name) = @_ |
efb592ef |
52 | my $__captures = $_[1]; |
53 | |
a30f41f7 |
54 | local $@; |
55 | local $SIG{__DIE__}; |
efb592ef |
56 | |
a30f41f7 |
57 | if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { |
58 | _dump_source(_make_source(@_), $_[2]); |
59 | } |
efb592ef |
60 | |
a30f41f7 |
61 | my $code = eval _make_source(@_); |
18b5b42a |
62 | my $e = $@; |
26eb0e7a |
63 | |
64 | if (!ref($code) || ref($code) ne 'CODE') { |
3eb05ecb |
65 | $e = "The 'source' parameter must return a subroutine reference, " |
66 | . "not $code"; |
26eb0e7a |
67 | undef $code; |
26eb0e7a |
68 | } |
69 | |
18b5b42a |
70 | return ($code, $e); |
efb592ef |
71 | } |
72 | |
73 | sub _make_source { |
74 | my ($source, $__captures) = @_; |
75 | return join "\n", ( |
76 | (map { |
77 | die "Capture key should start with \@, \% or \$: $_" |
78 | unless /^([\@\%\$])/; |
79 | 'my ' . $_ . ' = ' . $1 . '{$__captures->{\'' . $_ . '\'}};'; |
80 | } keys %$__captures), |
81 | $source, |
82 | ); |
83 | } |
84 | |
85 | sub _dump_source { |
86 | my ($source, $name) = @_; |
87 | |
88 | my $output; |
89 | if (try { require Perl::Tidy }) { |
90 | Perl::Tidy::perltidy( |
91 | source => \$source, |
92 | destination => \$output, |
93 | ); |
94 | } |
95 | else { |
96 | $output = $source; |
97 | } |
98 | |
99 | $name = defined($name) ? $name : "__ANON__"; |
100 | warn $name . ":\n" . $output . "\n"; |
101 | } |
102 | |
103 | 1; |