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