X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FEval%2FClosure.pm;h=42c20dadad6feccc46abfdd5b48fa47f83f421bc;hb=794dc9df98d2aaf2f143f32ac7dfa42fa46ce07e;hp=719701d2d0137ab178433fe6d6e0eb9d17f86a93;hpb=b86710e953dc6a4403be3f92ae7c1908f4584376;p=gitmo%2FEval-Closure.git diff --git a/lib/Eval/Closure.pm b/lib/Eval/Closure.pm index 719701d..42c20da 100644 --- a/lib/Eval/Closure.pm +++ b/lib/Eval/Closure.pm @@ -1,24 +1,122 @@ package Eval::Closure; +use strict; +use warnings; use Sub::Exporter -setup => { exports => [qw(eval_closure)], groups => { default => [qw(eval_closure)] }, }; +# ABSTRACT: safely and cleanly create closures via string eval use Carp; use overload (); use Scalar::Util qw(reftype); use Try::Tiny; +=head1 SYNOPSIS + + use Eval::Closure; + + my $code = eval_closure( + source => 'sub { $foo++ }', + environment => { + '$foo' => \1, + }, + ); + + warn $code->(); # 1 + warn $code->(); # 2 + + my $code2 = eval_closure( + source => 'sub { $code->() }', + ); # dies, $code isn't in scope + +=head1 DESCRIPTION + +String eval is often used for dynamic code generation. For instance, C +uses it heavily, to generate inlined versions of accessors and constructors, +which speeds code up at runtime by a significant amount. String eval is not +without its issues however - it's difficult to control the scope it's used in +(which determines which variables are in scope inside the eval), and it can be +quite slow, especially if doing a large number of evals. + +This module attempts to solve both of those problems. It provides an +C function, which evals a string in a clean environment, other +than a fixed list of specified variables. It also caches the result of the +eval, so that doing repeated evals of the same source, even with a different +environment, will be much faster (but note that the description is part of the +string to be evaled, so it must also be the same (or non-existent) if caching +is to work properly). + +=cut + +=func eval_closure(%args) + +This function provides the main functionality of this module. It is exported by +default. It takes a hash of parameters, with these keys being valid: + +=over 4 + +=item source + +The string to be evaled. It should end by returning a code reference. It can +access any variable declared in the C parameter (and only those +variables). It can be either a string, or an arrayref of lines (which will be +joined with newlines to produce the string). + +=item environment + +The environment to provide to the eval. This should be a hashref, mapping +variable names (including sigils) to references of the appropriate type. For +instance, a valid value for environment would be C<< { '@foo' => [] } >> (which +would allow the generated function to use an array named C<@foo>). Generally, +this is used to allow the generated function to access externally defined +variables (so you would pass in a reference to a variable that already exists). + +=item description + +This lets you provide a bit more information in backtraces. Normally, when a +function that was generated through string eval is called, that stack frame +will show up as "(eval n)", where 'n' is a sequential identifier for every +string eval that has happened so far in the program. Passing a C +parameter lets you override that to something more useful (for instance, +L overrides the description for accessors to something like "accessor +foo at MyClass.pm, line 123"). + +=item line + +This lets you override the particular line number that appears in backtraces, +much like the C option. The default is 1. + +=item terse_error + +Normally, this function appends the source code that failed to compile, and +prepends some explanatory text. Setting this option to true suppresses that +behavior so you get only the compilation error that Perl actually reported. + +=back + +=cut + sub eval_closure { my (%args) = @_; $args{source} = _canonicalize_source($args{source}); _validate_env($args{environment} ||= {}); - my ($code, $e) = _clean_eval_closure(@args{qw(source environment name)}); + $args{source} = _line_directive(@args{qw(line description)}) + . $args{source} + if defined $args{description} && !($^P & 0x10); + + my ($code, $e) = _clean_eval_closure(@args{qw(source environment)}); - croak("Failed to compile source: $e\n\nsource:\n$args{source}") - unless $code; + if (!$code) { + if ($args{terse_error}) { + die "$e\n"; + } + else { + croak("Failed to compile source: $e\n\nsource:\n$args{source}") + } + } return $code; } @@ -56,26 +154,35 @@ sub _validate_env { unless reftype($env) eq 'HASH'; for my $var (keys %$env) { - croak("Environment key '$_' should start with \@, \%, or \$") + croak("Environment key '$var' should start with \@, \%, or \$") unless $var =~ /^([\@\%\$])/; croak("Environment values must be references, not $env->{$var}") unless ref($env->{$var}); } } +sub _line_directive { + my ($line, $description) = @_; + + $line = 1 unless defined($line); + + return qq{#line $line "$description"\n}; +} + sub _clean_eval_closure { - # my ($source, $__captures, $name) = @_ - my $__captures = $_[1]; + my ($source, $captures) = @_; - local $@; - local $SIG{__DIE__}; + my @capture_keys = sort keys %$captures; if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { - _dump_source(_make_source(@_), $_[2]); + _dump_source(_make_compiler_source($source, @capture_keys)); } - my $code = eval _make_source(@_); - my $e = $@; + my ($compiler, $e) = _make_compiler($source, @capture_keys); + my $code; + if (defined $compiler) { + $code = $compiler->(@$captures{@capture_keys}); + } if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) { $e = "The 'source' parameter must return a subroutine reference, " @@ -86,33 +193,118 @@ sub _clean_eval_closure { return ($code, $e); } -sub _make_source { - my ($source, $__captures) = @_; +{ + my %compiler_cache; + + sub _make_compiler { + my $source = _make_compiler_source(@_); + + unless (exists $compiler_cache{$source}) { + $compiler_cache{$source} = _clean_eval($source); + } + + return @{ $compiler_cache{$source} }; + } +} + +$Eval::Closure::SANDBOX_ID = 0; + +sub _clean_eval { + $Eval::Closure::SANDBOX_ID++; + return eval <{\'' . $_ . '\'}};' - } keys %$__captures), + 'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};' + } @capture_keys), $source, + '}', ); } sub _dump_source { - my ($source, $name) = @_; + my ($source) = @_; my $output; if (try { require Perl::Tidy }) { Perl::Tidy::perltidy( source => \$source, destination => \$output, + argv => [], ); } else { $output = $source; } - $name = defined($name) ? $name : "__ANON__"; - warn $name . ":\n" . $output . "\n"; + warn "$output\n"; } +=head1 BUGS + +No known bugs. + +Please report any bugs through RT: email +C, or browse to +L. + +=head1 SEE ALSO + +=over 4 + +=item * L + +This module is a factoring out of code that used to live here + +=back + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Eval::Closure + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * RT: CPAN's request tracker + +L + +=item * Search CPAN + +L + +=back + +=head1 AUTHOR + +Jesse Luehrs + +Based on code from L, by Stevan Little and the +Moose Cabal. + +=cut + 1;