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, like 123").
  85
  86 =back
  87
  88 =cut
  89
  90 sub eval_closure {
  91     my (%args) = @_;
  92
  93     $args{source} = _canonicalize_source($args{source});
  94     _validate_env($args{environment} ||= {});
  95
  96     $args{source} = _line_directive($args{description}) . $args{source}
  97         if defined $args{description};
  98
  99     my ($code, $e) = _clean_eval_closure(@args{qw(source environment)});
 100
 101     croak("Failed to compile source: $e\n\nsource:\n$args{source}")
 102         unless $code;
 103
 104     return $code;
 105 }
 106
 107 sub _canonicalize_source {
 108     my ($source) = @_;
 109
 110     if (defined($source)) {
 111         if (ref($source)) {
 112             if (reftype($source) eq 'ARRAY'
 113              || overload::Method($source, '@{}')) {
 114                 return join "\n", @$source;
 115             }
 116             elsif (overload::Method($source, '""')) {
 117                 return "$source";
 118             }
 119             else {
 120                 croak("The 'source' parameter to eval_closure must be a "
 121                     . "string or array reference");
 122             }
 123         }
 124         else {
 125             return $source;
 126         }
 127     }
 128     else {
 129         croak("The 'source' parameter to eval_closure is required");
 130     }
 131 }
 132
 133 sub _validate_env {
 134     my ($env) = @_;
 135
 136     croak("The 'environment' parameter must be a hashref")
 137         unless reftype($env) eq 'HASH';
 138
 139     for my $var (keys %$env) {
 140         croak("Environment key '$var' should start with \@, \%, or \$")
 141             unless $var =~ /^([\@\%\$])/;
 142         croak("Environment values must be references, not $env->{$var}")
 143             unless ref($env->{$var});
 144     }
 145 }
 146
 147 sub _line_directive {
 148     my ($description) = @_;
 149
 150     return qq{#line 1 "$description"\n};
 151 }
 152
 153 sub _clean_eval_closure {
 154      my ($source, $captures) = @_;
 155
 156     if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) {
 157         _dump_source(_make_compiler_source(@_));
 158     }
 159
 160     my @capture_keys = sort keys %$captures;
 161     my ($compiler, $e) = _make_compiler($source, @capture_keys);
 162     my $code;
 163     if (defined $compiler) {
 164         $code = $compiler->(@$captures{@capture_keys});
 165     }
 166
 167     if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) {
 168         $e = "The 'source' parameter must return a subroutine reference, "
 169            . "not $code";
 170         undef $code;
 171     }
 172
 173     return ($code, $e);
 174 }
 175
 176 sub _make_compiler {
 177     local $@;
 178     local $SIG{__DIE__};
 179     my $compiler = eval _make_compiler_source(@_);
 180     my $e = $@;
 181     return ($compiler, $e);
 182 }
 183 memoize('_make_compiler');
 184
 185 sub _make_compiler_source {
 186     my ($source, @capture_keys) = @_;
 187     my $i = 0;
 188     return join "\n", (
 189         'sub {',
 190         (map {
 191             'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};'
 192          } @capture_keys),
 193         $source,
 194         '}',
 195     );
 196 }
 197
 198 sub _dump_source {
 199     my ($source) = @_;
 200
 201     my $output;
 202     if (try { require Perl::Tidy }) {
 203         Perl::Tidy::perltidy(
 204             source      => \$source,
 205             destination => \$output,
 206         );
 207     }
 208     else {
 209         $output = $source;
 210     }
 211
 212     warn "$output\n";
 213 }
 214
 215 =head1 BUGS
 216
 217 No known bugs.
 218
 219 Please report any bugs through RT: email
 220 C<bug-eval-closure at rt.cpan.org>, or browse to
 221 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Eval-Closure>.
 222
 223 =head1 SEE ALSO
 224
 225 =over 4
 226
 227 =item * L<Class::MOP::Method::Accessor>
 228
 229 This module is a factoring out of code that used to live here
 230
 231 =back
 232
 233 =head1 SUPPORT
 234
 235 You can find this documentation for this module with the perldoc command.
 236
 237     perldoc Eval::Closure
 238
 239 You can also look for information at:
 240
 241 =over 4
 242
 243 =item * AnnoCPAN: Annotated CPAN documentation
 244
 245 L<http://annocpan.org/dist/Eval-Closure>
 246
 247 =item * CPAN Ratings
 248
 249 L<http://cpanratings.perl.org/d/Eval-Closure>
 250
 251 =item * RT: CPAN's request tracker
 252
 253 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Eval-Closure>
 254
 255 =item * Search CPAN
 256
 257 L<http://search.cpan.org/dist/Eval-Closure>
 258
 259 =back
 260
 261 =head1 AUTHOR
 262
 263 Jesse Luehrs <doy at tozt dot net>
 264
 265 Based on code from L<Class::MOP::Method::Accessor>, by Stevan Little and the
 266 Moose Cabal.
 267
 268 =cut
 269
 270 1;