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