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 Memoize;
  13 use Scalar::Util qw(reftype);
  14 use Try::Tiny;
  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 can be
  41 quite slow, especially if doing a large number of evals.
  42
  43 This module attempts to solve both of those problems. It provides an
  44 C<eval_closure> function, which evals a string in a clean environment, other
  45 than a fixed list of specified variables. It also caches the result of the
  46 eval, so that doing repeated evals of the same source, even with a different
  47 environment, will be much faster (but note that the description is part of the
  48 string to be evaled, so it must also be the same (or non-existent) if caching
  49 is to work properly).
  50
  51 =cut
  52
  53 =func eval_closure(%args)
  54
  55 This function provides the main functionality of this module. It is exported by
  56 default. It takes a hash of parameters, with these keys being valid:
  57
  58 =over 4
  59
  60 =item source
  61
  62 The string to be evaled. It should end by returning a code reference. It can
  63 access any variable declared in the C<environment> parameter (and only those
  64 variables). It can be either a string, or an arrayref of lines (which will be
  65 joined with newlines to produce the string).
  66
  67 =item environment
  68
  69 The environment to provide to the eval. This should be a hashref, mapping
  70 variable names (including sigils) to references of the appropriate type. For
  71 instance, a valid value for environment would be C<< { '@foo' => [] } >> (which
  72 would allow the generated function to use an array named C<@foo>). Generally,
  73 this is used to allow the generated function to access externally defined
  74 variables (so you would pass in a reference to a variable that already exists).
  75
  76 =item description
  77
  78 This lets you provide a bit more information in backtraces. Normally, when a
  79 function that was generated through string eval is called, that stack frame
  80 will show up as "(eval n)", where 'n' is a sequential identifier for every
  81 string eval that has happened so far in the program. Passing a C<description>
  82 parameter lets you override that to something more useful (for instance,
  83 L<Moose> overrides the description for accessors to something like "accessor
  84 foo at MyClass.pm, line 123").
  85
  86 =item terse_error
  87
  88 Normally, this function appends the source code that failed to compile, and
  89 prepends some explanatory text. Setting this option to true suppresses that
  90 behavior so you get only the compilation error that Perl actually reported.
  91
  92 =back
  93
  94 =cut
  95
  96 sub eval_closure {
  97     my (%args) = @_;
  98
  99     $args{source} = _canonicalize_source($args{source});
 100     _validate_env($args{environment} ||= {});
 101
 102     $args{source} = _line_directive($args{description}) . $args{source}
 103         if defined $args{description};
 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 ($description) = @_;
 161
 162     return qq{#line 1 "$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;