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