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 Devel::Hints qw(cop_file cop_line);
  12 use overload ();
  13 use Memoize;
  14 use Scalar::Util qw(reftype);
  15 use Try::Tiny;
  16
  17 use constant USE_DEVEL_HINTS => ($] >= 5.010);
  18
  19 =head1 SYNOPSIS
  20
  21   use Eval::Closure;
  22
  23   my $code = eval_closure(
  24       source      => 'sub { $foo++ }',
  25       environment => {
  26           '$foo' => \1,
  27       },
  28   );
  29
  30   warn $code->(); # 1
  31   warn $code->(); # 2
  32
  33   my $code2 = eval_closure(
  34       source => 'sub { $code->() }',
  35   ); # dies, $code isn't in scope
  36
  37 =head1 DESCRIPTION
  38
  39 String eval is often used for dynamic code generation. For instance, C<Moose>
  40 uses it heavily, to generate inlined versions of accessors and constructors,
  41 which speeds code up at runtime by a significant amount. String eval is not
  42 without its issues however - it's difficult to control the scope it's used in
  43 (which determines which variables are in scope inside the eval), and it can be
  44 quite slow, especially if doing a large number of evals.
  45
  46 This module attempts to solve both of those problems. It provides an
  47 C<eval_closure> function, which evals a string in a clean environment, other
  48 than a fixed list of specified variables. It also caches the result of the
  49 eval, so that doing repeated evals of the same source, even with a different
  50 environment, will be much faster (but note that the description is part of the
  51 string to be evaled, so it must also be the same (or non-existent) if caching
  52 is to work properly).
  53
  54 =cut
  55
  56 =func eval_closure(%args)
  57
  58 This function provides the main functionality of this module. It is exported by
  59 default. It takes a hash of parameters, with these keys being valid:
  60
  61 =over 4
  62
  63 =item source
  64
  65 The string to be evaled. It should end by returning a code reference. It can
  66 access any variable declared in the C<environment> parameter (and only those
  67 variables). It can be either a string, or an arrayref of lines (which will be
  68 joined with newlines to produce the string).
  69
  70 =item environment
  71
  72 The environment to provide to the eval. This should be a hashref, mapping
  73 variable names (including sigils) to references of the appropriate type. For
  74 instance, a valid value for environment would be C<< { '@foo' => [] } >> (which
  75 would allow the generated function to use an array named C<@foo>). Generally,
  76 this is used to allow the generated function to access externally defined
  77 variables (so you would pass in a reference to a variable that already exists).
  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, like 123").
  88
  89 =back
  90
  91 =cut
  92
  93 sub eval_closure {
  94     my (%args) = @_;
  95
  96     $args{source} = _canonicalize_source($args{source});
  97     _validate_env($args{environment} ||= {});
  98
  99     if (!USE_DEVEL_HINTS) {
 100         $args{source} = _line_directive($args{description}) . $args{source}
 101             if defined $args{description};
 102     }
 103
 104     my ($code, $e) = _clean_eval_closure(@args{qw(source environment)});
 105
 106     croak("Failed to compile source: $e\n\nsource:\n$args{source}")
 107         unless $code;
 108
 109     if (USE_DEVEL_HINTS) {
 110         if (defined $args{description}) {
 111             cop_file($code, $args{description});
 112             cop_line($code, 1);
 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 ($description) = @_;
 161
 162     return qq{#line 0 "$description"\n};
 163 }
 164
 165 sub _clean_eval_closure {
 166      my ($source, $captures) = @_;
 167
 168     if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) {
 169         _dump_source(_make_compiler_source(@_));
 170     }
 171
 172     my @capture_keys = sort keys %$captures;
 173     my ($compiler, $e) = _make_compiler($source, @capture_keys);
 174     my $code;
 175     if (defined $compiler) {
 176         $code = $compiler->(@$captures{@capture_keys});
 177     }
 178
 179     if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) {
 180         $e = "The 'source' parameter must return a subroutine reference, "
 181            . "not $code";
 182         undef $code;
 183     }
 184
 185     return ($code, $e);
 186 }
 187
 188 sub _make_compiler {
 189     local $@;
 190     local $SIG{__DIE__};
 191     my $compiler = eval _make_compiler_source(@_);
 192     my $e = $@;
 193     return ($compiler, $e);
 194 }
 195 memoize('_make_compiler');
 196
 197 sub _make_compiler_source {
 198     my ($source, @capture_keys) = @_;
 199     my $i = 0;
 200     return join "\n", (
 201         'sub {',
 202         (map {
 203             'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};'
 204          } @capture_keys),
 205         $source,
 206         '}',
 207     );
 208 }
 209
 210 sub _dump_source {
 211     my ($source) = @_;
 212
 213     my $output;
 214     if (try { require Perl::Tidy }) {
 215         Perl::Tidy::perltidy(
 216             source      => \$source,
 217             destination => \$output,
 218         );
 219     }
 220     else {
 221         $output = $source;
 222     }
 223
 224     warn "$output\n";
 225 }
 226
 227 =head1 BUGS
 228
 229 No known bugs.
 230
 231 Please report any bugs through RT: email
 232 C<bug-eval-closure at rt.cpan.org>, or browse to
 233 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Eval-Closure>.
 234
 235 =head1 SEE ALSO
 236
 237 =over 4
 238
 239 =item * L<Class::MOP::Method::Accessor>
 240
 241 This module is a factoring out of code that used to live here
 242
 243 =back
 244
 245 =head1 SUPPORT
 246
 247 You can find this documentation for this module with the perldoc command.
 248
 249     perldoc Eval::Closure
 250
 251 You can also look for information at:
 252
 253 =over 4
 254
 255 =item * AnnoCPAN: Annotated CPAN documentation
 256
 257 L<http://annocpan.org/dist/Eval-Closure>
 258
 259 =item * CPAN Ratings
 260
 261 L<http://cpanratings.perl.org/d/Eval-Closure>
 262
 263 =item * RT: CPAN's request tracker
 264
 265 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Eval-Closure>
 266
 267 =item * Search CPAN
 268
 269 L<http://search.cpan.org/dist/Eval-Closure>
 270
 271 =back
 272
 273 =head1 AUTHOR
 274
 275 Jesse Luehrs <doy at tozt dot net>
 276
 277 Based on code from L<Class::MOP::Method::Accessor>, by Stevan Little and the
 278 Moose Cabal.
 279
 280 =cut
 281
 282 1;