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