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