From cf3c05406f7cde406764915682e4bf5db73b1bdd Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Tue, 12 May 2015 04:54:59 +0000 Subject: Eval-Closure-0.13 --- lib/Eval/Closure.pm | 371 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 371 insertions(+) create mode 100644 lib/Eval/Closure.pm (limited to 'lib') diff --git a/lib/Eval/Closure.pm b/lib/Eval/Closure.pm new file mode 100644 index 0000000..292c453 --- /dev/null +++ b/lib/Eval/Closure.pm @@ -0,0 +1,371 @@ +package Eval::Closure; +BEGIN { + $Eval::Closure::AUTHORITY = 'cpan:DOY'; +} +$Eval::Closure::VERSION = '0.13'; +use strict; +use warnings; +# ABSTRACT: safely and cleanly create closures via string eval + +use Exporter 'import'; +@Eval::Closure::EXPORT = @Eval::Closure::EXPORT_OK = 'eval_closure'; + +use Carp; +use overload (); +use Scalar::Util qw(reftype); +use Try::Tiny; + +use constant HAS_LEXICAL_SUBS => $] >= 5.018; + + + +sub eval_closure { + my (%args) = @_; + + # default to copying environment + $args{alias} = 0 if !exists $args{alias}; + + $args{source} = _canonicalize_source($args{source}); + _validate_env($args{environment} ||= {}); + + $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 alias)}); + + if (!$code) { + if ($args{terse_error}) { + die "$e\n"; + } + else { + croak("Failed to compile source: $e\n\nsource:\n$args{source}") + } + } + + return $code; +} + +sub _canonicalize_source { + my ($source) = @_; + + if (defined($source)) { + if (ref($source)) { + if (reftype($source) eq 'ARRAY' + || overload::Method($source, '@{}')) { + return join "\n", @$source; + } + elsif (overload::Method($source, '""')) { + return "$source"; + } + else { + croak("The 'source' parameter to eval_closure must be a " + . "string or array reference"); + } + } + else { + return $source; + } + } + else { + croak("The 'source' parameter to eval_closure is required"); + } +} + +sub _validate_env { + my ($env) = @_; + + croak("The 'environment' parameter must be a hashref") + unless reftype($env) eq 'HASH'; + + for my $var (keys %$env) { + if (HAS_LEXICAL_SUBS) { + croak("Environment key '$var' should start with \@, \%, \$, or \&") + unless $var =~ /^([\@\%\$\&])/; + } + else { + 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, $alias) = @_; + + my @capture_keys = sort keys %$captures; + + if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { + _dump_source(_make_compiler_source($source, $alias, @capture_keys)); + } + + my ($compiler, $e) = _make_compiler($source, $alias, @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, " + . "not $code"; + undef $code; + } + + if ($alias) { + require Devel::LexAlias; + Devel::LexAlias::lexalias($code, $_, $captures->{$_}) + for grep !/^\&/, keys %$captures; + } + + return ($code, $e); +} + +sub _make_compiler { + my $source = _make_compiler_source(@_); + + return @{ _clean_eval($source) }; +} + +sub _clean_eval { + local $@; + local $SIG{__DIE__}; + my $compiler = eval $_[0]; + my $e = $@; + [ $compiler, $e ]; +} + +$Eval::Closure::SANDBOX_ID = 0; + +sub _make_compiler_source { + my ($source, $alias, @capture_keys) = @_; + $Eval::Closure::SANDBOX_ID++; + my $i = 0; + return join "\n", ( + "package Eval::Closure::Sandbox_$Eval::Closure::SANDBOX_ID;", + 'sub {', + (map { _make_lexical_assignment($_, $i++, $alias) } @capture_keys), + $source, + '}', + ); +} + +sub _make_lexical_assignment { + my ($key, $index, $alias) = @_; + my $sigil = substr($key, 0, 1); + my $name = substr($key, 1); + if (HAS_LEXICAL_SUBS && $sigil eq '&') { + my $tmpname = '$__' . $name . '__' . $index; + return 'use feature "lexical_subs"; ' + . 'no warnings "experimental::lexical_subs"; ' + . 'my ' . $tmpname . ' = $_[' . $index . ']; ' + . 'my sub ' . $name . ' { goto ' . $tmpname . ' }'; + } + if ($alias) { + return 'my ' . $key . ';'; + } + else { + return 'my ' . $key . ' = ' . $sigil . '{$_[' . $index . ']};'; + } +} + +sub _dump_source { + my ($source) = @_; + + my $output; + if (try { require Perl::Tidy }) { + Perl::Tidy::perltidy( + source => \$source, + destination => \$output, + argv => [], + ); + } + else { + $output = $source; + } + + warn "$output\n"; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Eval::Closure - safely and cleanly create closures via string eval + +=head1 VERSION + +version 0.13 + +=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's easy +to miss compilation errors, since eval catches them and sticks them in $@ +instead. + +This module attempts to solve these problems. It provides an C +function, which evals a string in a clean environment, other than a fixed list +of specified variables. Compilation errors are rethrown automatically. + +=head1 FUNCTIONS + +=head2 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). + +In perl 5.18 and greater, the environment hash can contain variables with a +sigil of C<&>. This will create a lexical sub in the evaluated code (see +L). Using a C<&> sigil on perl versions +before lexical subs were available will throw an error. + +=item alias + +If set to true, the coderef returned closes over the variables referenced in +the environment hashref. (This feature requires L.) If set to +false, the coderef closes over a I<< shallow copy >> of the variables. + +If this argument is omitted, Eval::Closure will currently assume false, but +this assumption may change in a future version. + +=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 + +=head1 BUGS + +No known bugs. + +Please report any bugs to GitHub Issues at +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 * MetaCPAN + +L + +=item * Github + +L + +=item * RT: CPAN's request tracker + +L + +=item * CPAN Ratings + +L + +=back + +=head1 NOTES + +Based on code from L, by Stevan Little and the +Moose Cabal. + +=head1 AUTHOR + +Jesse Luehrs + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2015 by Jesse Luehrs. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut -- cgit v1.2.1