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