lib/Eval/Closure.pm

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