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