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 | }; |
ed9a00ae |
8 | # ABSTRACT: safely and cleanly create closures via string eval |
efb592ef |
9 | |
10 | use Carp; |
11 | use overload (); |
61717119 |
12 | use Memoize; |
efb592ef |
13 | use Scalar::Util qw(reftype); |
14 | use Try::Tiny; |
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 |
40 | (which determines which variables are in scope inside the eval), and it can be |
41 | quite slow, especially if doing a large number of evals. |
42 | |
43 | This module attempts to solve both of those problems. It provides an |
44 | C<eval_closure> function, which evals a string in a clean environment, other |
45 | than a fixed list of specified variables. It also caches the result of the |
c524c0f3 |
46 | eval, so that doing repeated evals of the same source, even with a different |
47 | environment, will be much faster (but note that the description is part of the |
48 | string to be evaled, so it must also be the same (or non-existent) if caching |
49 | is to work properly). |
2e6086ab |
50 | |
ed9a00ae |
51 | =cut |
52 | |
53 | =func eval_closure(%args) |
54 | |
2e6086ab |
55 | This function provides the main functionality of this module. It is exported by |
56 | default. It takes a hash of parameters, with these keys being valid: |
57 | |
58 | =over 4 |
59 | |
60 | =item source |
61 | |
62 | The string to be evaled. It should end by returning a code reference. It can |
63 | access any variable declared in the C<environment> parameter (and only those |
64 | variables). It can be either a string, or an arrayref of lines (which will be |
65 | joined with newlines to produce the string). |
66 | |
67 | =item environment |
68 | |
69 | The environment to provide to the eval. This should be a hashref, mapping |
70 | variable names (including sigils) to references of the appropriate type. For |
71 | instance, a valid value for environment would be C<< { '@foo' => [] } >> (which |
72 | would allow the generated function to use an array named C<@foo>). Generally, |
73 | this is used to allow the generated function to access externally defined |
74 | variables (so you would pass in a reference to a variable that already exists). |
75 | |
76 | =item description |
77 | |
78 | This lets you provide a bit more information in backtraces. Normally, when a |
79 | function that was generated through string eval is called, that stack frame |
80 | will show up as "(eval n)", where 'n' is a sequential identifier for every |
81 | string eval that has happened so far in the program. Passing a C<description> |
82 | parameter lets you override that to something more useful (for instance, |
83 | L<Moose> overrides the description for accessors to something like "accessor |
84 | foo at MyClass.pm, like 123"). |
85 | |
86 | =back |
87 | |
ed9a00ae |
88 | =cut |
89 | |
efb592ef |
90 | sub eval_closure { |
91 | my (%args) = @_; |
8e1b3d7b |
92 | |
efb592ef |
93 | $args{source} = _canonicalize_source($args{source}); |
8e1b3d7b |
94 | _validate_env($args{environment} ||= {}); |
efb592ef |
95 | |
68cb1ade |
96 | $args{source} = _line_directive($args{description}) . $args{source} |
97 | if defined $args{description}; |
3efcc087 |
98 | |
409b8f41 |
99 | my ($code, $e) = _clean_eval_closure(@args{qw(source environment)}); |
efb592ef |
100 | |
101 | croak("Failed to compile source: $e\n\nsource:\n$args{source}") |
102 | unless $code; |
103 | |
104 | return $code; |
105 | } |
106 | |
107 | sub _canonicalize_source { |
108 | my ($source) = @_; |
109 | |
110 | if (defined($source)) { |
111 | if (ref($source)) { |
112 | if (reftype($source) eq 'ARRAY' |
113 | || overload::Method($source, '@{}')) { |
114 | return join "\n", @$source; |
115 | } |
116 | elsif (overload::Method($source, '""')) { |
117 | return "$source"; |
118 | } |
119 | else { |
120 | croak("The 'source' parameter to eval_closure must be a " |
121 | . "string or array reference"); |
122 | } |
123 | } |
124 | else { |
125 | return $source; |
126 | } |
127 | } |
128 | else { |
129 | croak("The 'source' parameter to eval_closure is required"); |
130 | } |
131 | } |
132 | |
8e1b3d7b |
133 | sub _validate_env { |
134 | my ($env) = @_; |
135 | |
136 | croak("The 'environment' parameter must be a hashref") |
137 | unless reftype($env) eq 'HASH'; |
138 | |
139 | for my $var (keys %$env) { |
b3bd5eb8 |
140 | croak("Environment key '$var' should start with \@, \%, or \$") |
8e1b3d7b |
141 | unless $var =~ /^([\@\%\$])/; |
142 | croak("Environment values must be references, not $env->{$var}") |
143 | unless ref($env->{$var}); |
144 | } |
145 | } |
146 | |
3efcc087 |
147 | sub _line_directive { |
148 | my ($description) = @_; |
149 | |
68cb1ade |
150 | return qq{#line 1 "$description"\n}; |
3efcc087 |
151 | } |
152 | |
efb592ef |
153 | sub _clean_eval_closure { |
f3c27658 |
154 | my ($source, $captures) = @_; |
efb592ef |
155 | |
a30f41f7 |
156 | if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { |
f3c27658 |
157 | _dump_source(_make_compiler_source(@_)); |
a30f41f7 |
158 | } |
efb592ef |
159 | |
53b0abc5 |
160 | my @capture_keys = sort keys %$captures; |
447800b5 |
161 | my ($compiler, $e) = _make_compiler($source, @capture_keys); |
f3c27658 |
162 | my $code; |
163 | if (defined $compiler) { |
447800b5 |
164 | $code = $compiler->(@$captures{@capture_keys}); |
f3c27658 |
165 | } |
26eb0e7a |
166 | |
b86710e9 |
167 | if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) { |
3eb05ecb |
168 | $e = "The 'source' parameter must return a subroutine reference, " |
169 | . "not $code"; |
26eb0e7a |
170 | undef $code; |
26eb0e7a |
171 | } |
172 | |
18b5b42a |
173 | return ($code, $e); |
efb592ef |
174 | } |
175 | |
f3c27658 |
176 | sub _make_compiler { |
177 | local $@; |
178 | local $SIG{__DIE__}; |
179 | my $compiler = eval _make_compiler_source(@_); |
180 | my $e = $@; |
181 | return ($compiler, $e); |
182 | } |
61717119 |
183 | memoize('_make_compiler'); |
f3c27658 |
184 | |
185 | sub _make_compiler_source { |
447800b5 |
186 | my ($source, @capture_keys) = @_; |
f3c27658 |
187 | my $i = 0; |
efb592ef |
188 | return join "\n", ( |
f3c27658 |
189 | 'sub {', |
efb592ef |
190 | (map { |
f3c27658 |
191 | 'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};' |
447800b5 |
192 | } @capture_keys), |
efb592ef |
193 | $source, |
f3c27658 |
194 | '}', |
efb592ef |
195 | ); |
196 | } |
197 | |
198 | sub _dump_source { |
409b8f41 |
199 | my ($source) = @_; |
efb592ef |
200 | |
201 | my $output; |
202 | if (try { require Perl::Tidy }) { |
203 | Perl::Tidy::perltidy( |
204 | source => \$source, |
205 | destination => \$output, |
206 | ); |
207 | } |
208 | else { |
209 | $output = $source; |
210 | } |
211 | |
409b8f41 |
212 | warn "$output\n"; |
efb592ef |
213 | } |
214 | |
ed9a00ae |
215 | =head1 BUGS |
216 | |
217 | No known bugs. |
218 | |
219 | Please report any bugs through RT: email |
220 | C<bug-eval-closure at rt.cpan.org>, or browse to |
221 | L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Eval-Closure>. |
222 | |
223 | =head1 SEE ALSO |
224 | |
225 | =over 4 |
226 | |
227 | =item * L<Class::MOP::Method::Accessor> |
228 | |
229 | This module is a factoring out of code that used to live here |
230 | |
231 | =back |
232 | |
233 | =head1 SUPPORT |
234 | |
235 | You can find this documentation for this module with the perldoc command. |
236 | |
237 | perldoc Eval::Closure |
238 | |
239 | You can also look for information at: |
240 | |
241 | =over 4 |
242 | |
243 | =item * AnnoCPAN: Annotated CPAN documentation |
244 | |
245 | L<http://annocpan.org/dist/Eval-Closure> |
246 | |
247 | =item * CPAN Ratings |
248 | |
249 | L<http://cpanratings.perl.org/d/Eval-Closure> |
250 | |
251 | =item * RT: CPAN's request tracker |
252 | |
253 | L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Eval-Closure> |
254 | |
255 | =item * Search CPAN |
256 | |
257 | L<http://search.cpan.org/dist/Eval-Closure> |
258 | |
259 | =back |
260 | |
261 | =head1 AUTHOR |
262 | |
263 | Jesse Luehrs <doy at tozt dot net> |
264 | |
265 | Based on code from L<Class::MOP::Method::Accessor>, by Stevan Little and the |
266 | Moose Cabal. |
267 | |
268 | =cut |
269 | |
efb592ef |
270 | 1; |