Commit | Line | Data |
efb592ef |
1 | package Eval::Closure; |
b3bd5eb8 |
2 | use strict; |
3 | use warnings; |
ed9a00ae |
4 | # ABSTRACT: safely and cleanly create closures via string eval |
efb592ef |
5 | |
c723eebe |
6 | use Exporter 'import'; |
7 | @Eval::Closure::EXPORT = @Eval::Closure::EXPORT_OK = 'eval_closure'; |
8 | |
efb592ef |
9 | use Carp; |
10 | use overload (); |
11 | use Scalar::Util qw(reftype); |
12 | use Try::Tiny; |
13 | |
a55b2a20 |
14 | use constant HAS_LEXICAL_SUBS => $] >= 5.018; |
15 | |
ed9a00ae |
16 | =head1 SYNOPSIS |
17 | |
2e6086ab |
18 | use Eval::Closure; |
19 | |
20 | my $code = eval_closure( |
21 | source => 'sub { $foo++ }', |
22 | environment => { |
23 | '$foo' => \1, |
24 | }, |
25 | ); |
26 | |
27 | warn $code->(); # 1 |
28 | warn $code->(); # 2 |
29 | |
30 | my $code2 = eval_closure( |
31 | source => 'sub { $code->() }', |
32 | ); # dies, $code isn't in scope |
33 | |
ed9a00ae |
34 | =head1 DESCRIPTION |
35 | |
2e6086ab |
36 | String eval is often used for dynamic code generation. For instance, C<Moose> |
37 | uses it heavily, to generate inlined versions of accessors and constructors, |
38 | which speeds code up at runtime by a significant amount. String eval is not |
39 | without its issues however - it's difficult to control the scope it's used in |
9b61f781 |
40 | (which determines which variables are in scope inside the eval), and it's easy |
41 | to miss compilation errors, since eval catches them and sticks them in $@ |
42 | instead. |
2e6086ab |
43 | |
9b61f781 |
44 | This module attempts to solve these problems. It provides an C<eval_closure> |
fa287851 |
45 | function, which evals a string in a clean environment, other than a fixed list |
9b61f781 |
46 | of specified variables. Compilation errors are rethrown automatically. |
2e6086ab |
47 | |
ed9a00ae |
48 | =cut |
49 | |
50 | =func eval_closure(%args) |
51 | |
2e6086ab |
52 | This function provides the main functionality of this module. It is exported by |
53 | default. It takes a hash of parameters, with these keys being valid: |
54 | |
55 | =over 4 |
56 | |
57 | =item source |
58 | |
59 | The string to be evaled. It should end by returning a code reference. It can |
60 | access any variable declared in the C<environment> parameter (and only those |
61 | variables). It can be either a string, or an arrayref of lines (which will be |
62 | joined with newlines to produce the string). |
63 | |
64 | =item environment |
65 | |
66 | The environment to provide to the eval. This should be a hashref, mapping |
67 | variable names (including sigils) to references of the appropriate type. For |
68 | instance, a valid value for environment would be C<< { '@foo' => [] } >> (which |
69 | would allow the generated function to use an array named C<@foo>). Generally, |
70 | this is used to allow the generated function to access externally defined |
71 | variables (so you would pass in a reference to a variable that already exists). |
72 | |
a55b2a20 |
73 | In perl 5.18 and greater, the environment hash can contain variables with a |
74 | sigil of C<&>. This will create a lexical sub in the evaluated code (see |
75 | L<feature/The 'lexical_subs' feature>). Using a C<&> sigil on perl versions |
76 | before lexical subs were available will throw an error. |
77 | |
2e6086ab |
78 | =item description |
79 | |
80 | This lets you provide a bit more information in backtraces. Normally, when a |
81 | function that was generated through string eval is called, that stack frame |
82 | will show up as "(eval n)", where 'n' is a sequential identifier for every |
83 | string eval that has happened so far in the program. Passing a C<description> |
84 | parameter lets you override that to something more useful (for instance, |
85 | L<Moose> overrides the description for accessors to something like "accessor |
c4318911 |
86 | foo at MyClass.pm, line 123"). |
2e6086ab |
87 | |
75e6988b |
88 | =item line |
89 | |
90 | This lets you override the particular line number that appears in backtraces, |
c8d4a65f |
91 | much like the C<description> option. The default is 1. |
75e6988b |
92 | |
5617e966 |
93 | =item terse_error |
94 | |
95 | Normally, this function appends the source code that failed to compile, and |
96 | prepends some explanatory text. Setting this option to true suppresses that |
97 | behavior so you get only the compilation error that Perl actually reported. |
98 | |
2e6086ab |
99 | =back |
100 | |
ed9a00ae |
101 | =cut |
102 | |
efb592ef |
103 | sub eval_closure { |
104 | my (%args) = @_; |
8e1b3d7b |
105 | |
efb592ef |
106 | $args{source} = _canonicalize_source($args{source}); |
8e1b3d7b |
107 | _validate_env($args{environment} ||= {}); |
efb592ef |
108 | |
c8d4a65f |
109 | $args{source} = _line_directive(@args{qw(line description)}) |
110 | . $args{source} |
04918f80 |
111 | if defined $args{description} && !($^P & 0x10); |
3efcc087 |
112 | |
409b8f41 |
113 | my ($code, $e) = _clean_eval_closure(@args{qw(source environment)}); |
efb592ef |
114 | |
5617e966 |
115 | if (!$code) { |
116 | if ($args{terse_error}) { |
117 | die "$e\n"; |
118 | } |
119 | else { |
120 | croak("Failed to compile source: $e\n\nsource:\n$args{source}") |
121 | } |
122 | } |
efb592ef |
123 | |
124 | return $code; |
125 | } |
126 | |
127 | sub _canonicalize_source { |
128 | my ($source) = @_; |
129 | |
130 | if (defined($source)) { |
131 | if (ref($source)) { |
132 | if (reftype($source) eq 'ARRAY' |
133 | || overload::Method($source, '@{}')) { |
134 | return join "\n", @$source; |
135 | } |
136 | elsif (overload::Method($source, '""')) { |
137 | return "$source"; |
138 | } |
139 | else { |
140 | croak("The 'source' parameter to eval_closure must be a " |
141 | . "string or array reference"); |
142 | } |
143 | } |
144 | else { |
145 | return $source; |
146 | } |
147 | } |
148 | else { |
149 | croak("The 'source' parameter to eval_closure is required"); |
150 | } |
151 | } |
152 | |
8e1b3d7b |
153 | sub _validate_env { |
154 | my ($env) = @_; |
155 | |
156 | croak("The 'environment' parameter must be a hashref") |
157 | unless reftype($env) eq 'HASH'; |
158 | |
159 | for my $var (keys %$env) { |
a55b2a20 |
160 | if (HAS_LEXICAL_SUBS) { |
161 | croak("Environment key '$var' should start with \@, \%, \$, or \&") |
162 | unless $var =~ /^([\@\%\$\&])/; |
163 | } |
164 | else { |
165 | croak("Environment key '$var' should start with \@, \%, or \$") |
166 | unless $var =~ /^([\@\%\$])/; |
167 | } |
8e1b3d7b |
168 | croak("Environment values must be references, not $env->{$var}") |
169 | unless ref($env->{$var}); |
170 | } |
171 | } |
172 | |
3efcc087 |
173 | sub _line_directive { |
75e6988b |
174 | my ($line, $description) = @_; |
175 | |
c8d4a65f |
176 | $line = 1 unless defined($line); |
3efcc087 |
177 | |
75e6988b |
178 | return qq{#line $line "$description"\n}; |
3efcc087 |
179 | } |
180 | |
efb592ef |
181 | sub _clean_eval_closure { |
1a2acf75 |
182 | my ($source, $captures) = @_; |
efb592ef |
183 | |
25ef0135 |
184 | my @capture_keys = sort keys %$captures; |
185 | |
a30f41f7 |
186 | if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { |
25ef0135 |
187 | _dump_source(_make_compiler_source($source, @capture_keys)); |
a30f41f7 |
188 | } |
efb592ef |
189 | |
447800b5 |
190 | my ($compiler, $e) = _make_compiler($source, @capture_keys); |
f3c27658 |
191 | my $code; |
192 | if (defined $compiler) { |
447800b5 |
193 | $code = $compiler->(@$captures{@capture_keys}); |
f3c27658 |
194 | } |
26eb0e7a |
195 | |
b86710e9 |
196 | if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) { |
3eb05ecb |
197 | $e = "The 'source' parameter must return a subroutine reference, " |
198 | . "not $code"; |
26eb0e7a |
199 | undef $code; |
26eb0e7a |
200 | } |
201 | |
18b5b42a |
202 | return ($code, $e); |
efb592ef |
203 | } |
204 | |
fa287851 |
205 | sub _make_compiler { |
206 | my $source = _make_compiler_source(@_); |
74225234 |
207 | |
fa287851 |
208 | return @{ _clean_eval($source) }; |
f3c27658 |
209 | } |
210 | |
0fb2ea46 |
211 | sub _clean_eval { |
01a39ce3 |
212 | local $@; |
213 | local $SIG{__DIE__}; |
214 | my $compiler = eval $_[0]; |
215 | my $e = $@; |
216 | [ $compiler, $e ]; |
0fb2ea46 |
217 | } |
218 | |
e6c246fb |
219 | $Eval::Closure::SANDBOX_ID = 0; |
220 | |
f3c27658 |
221 | sub _make_compiler_source { |
447800b5 |
222 | my ($source, @capture_keys) = @_; |
e6c246fb |
223 | $Eval::Closure::SANDBOX_ID++; |
f3c27658 |
224 | my $i = 0; |
efb592ef |
225 | return join "\n", ( |
e6c246fb |
226 | "package Eval::Closure::Sandbox_$Eval::Closure::SANDBOX_ID;", |
f3c27658 |
227 | 'sub {', |
a55b2a20 |
228 | (map { _make_lexical_assignment($_, $i++) } @capture_keys), |
229 | $source, |
f3c27658 |
230 | '}', |
efb592ef |
231 | ); |
232 | } |
233 | |
a55b2a20 |
234 | sub _make_lexical_assignment { |
235 | my ($key, $index) = @_; |
236 | my $sigil = substr($key, 0, 1); |
237 | my $name = substr($key, 1); |
238 | if (HAS_LEXICAL_SUBS && $sigil eq '&') { |
239 | my $tmpname = '$__' . $name . '__' . $index; |
240 | return 'use feature "lexical_subs"; ' |
241 | . 'no warnings "experimental::lexical_subs"; ' |
242 | . 'my ' . $tmpname . ' = $_[' . $index . ']; ' |
243 | . 'my sub ' . $name . ' { goto ' . $tmpname . ' }'; |
244 | } |
245 | else { |
246 | return 'my ' . $key . ' = ' . $sigil . '{$_[' . $index . ']};'; |
247 | } |
248 | } |
249 | |
efb592ef |
250 | sub _dump_source { |
409b8f41 |
251 | my ($source) = @_; |
efb592ef |
252 | |
253 | my $output; |
254 | if (try { require Perl::Tidy }) { |
255 | Perl::Tidy::perltidy( |
256 | source => \$source, |
257 | destination => \$output, |
9688c823 |
258 | argv => [], |
efb592ef |
259 | ); |
260 | } |
261 | else { |
262 | $output = $source; |
263 | } |
264 | |
409b8f41 |
265 | warn "$output\n"; |
efb592ef |
266 | } |
267 | |
ed9a00ae |
268 | =head1 BUGS |
269 | |
270 | No known bugs. |
271 | |
e52ba311 |
272 | Please report any bugs to GitHub Issues at L<https://github.com/doy/eval-closure/issues>. |
ed9a00ae |
273 | |
274 | =head1 SEE ALSO |
275 | |
276 | =over 4 |
277 | |
278 | =item * L<Class::MOP::Method::Accessor> |
279 | |
280 | This module is a factoring out of code that used to live here |
281 | |
282 | =back |
283 | |
284 | =head1 SUPPORT |
285 | |
286 | You can find this documentation for this module with the perldoc command. |
287 | |
288 | perldoc Eval::Closure |
289 | |
290 | You can also look for information at: |
291 | |
292 | =over 4 |
293 | |
e52ba311 |
294 | =item * MetaCPAN |
ed9a00ae |
295 | |
e52ba311 |
296 | L<https://metacpan.org/release/Reply> |
ed9a00ae |
297 | |
e52ba311 |
298 | =item * Github |
ed9a00ae |
299 | |
e52ba311 |
300 | L<https://github.com/doy/reply> |
ed9a00ae |
301 | |
302 | =item * RT: CPAN's request tracker |
303 | |
e52ba311 |
304 | L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Reply> |
ed9a00ae |
305 | |
e52ba311 |
306 | =item * CPAN Ratings |
ed9a00ae |
307 | |
e52ba311 |
308 | L<http://cpanratings.perl.org/d/Reply> |
ed9a00ae |
309 | |
310 | =back |
311 | |
e52ba311 |
312 | =head1 NOTES |
ed9a00ae |
313 | |
314 | Based on code from L<Class::MOP::Method::Accessor>, by Stevan Little and the |
315 | Moose Cabal. |
316 | |
317 | =cut |
318 | |
efb592ef |
319 | 1; |