lib/Eval/Closure.pm

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