lib/Eval/Closure.pm

   1 package Eval::Closure;
   2 use Sub::Exporter -setup => {
   3     exports => [qw(eval_closure)],
   4     groups  => { default => [qw(eval_closure)] },
   5 };
   6
   7 use Carp;
   8 use overload ();
   9 use Scalar::Util qw(reftype);
  10 use Try::Tiny;
  11
  12 sub eval_closure {
  13     my (%args) = @_;
  14
  15     $args{source} = _canonicalize_source($args{source});
  16     _validate_env($args{environment} ||= {});
  17
  18     my ($code, $e) = _clean_eval_closure(@args{qw(source environment name)});
  19
  20     croak("Failed to compile source: $e\n\nsource:\n$args{source}")
  21         unless $code;
  22
  23     return $code;
  24 }
  25
  26 sub _canonicalize_source {
  27     my ($source) = @_;
  28
  29     if (defined($source)) {
  30         if (ref($source)) {
  31             if (reftype($source) eq 'ARRAY'
  32              || overload::Method($source, '@{}')) {
  33                 return join "\n", @$source;
  34             }
  35             elsif (overload::Method($source, '""')) {
  36                 return "$source";
  37             }
  38             else {
  39                 croak("The 'source' parameter to eval_closure must be a "
  40                     . "string or array reference");
  41             }
  42         }
  43         else {
  44             return $source;
  45         }
  46     }
  47     else {
  48         croak("The 'source' parameter to eval_closure is required");
  49     }
  50 }
  51
  52 sub _validate_env {
  53     my ($env) = @_;
  54
  55     croak("The 'environment' parameter must be a hashref")
  56         unless reftype($env) eq 'HASH';
  57
  58     for my $var (keys %$env) {
  59         croak("Environment key '$_' should start with \@, \%, or \$")
  60             unless $var =~ /^([\@\%\$])/;
  61         croak("Environment values must be references, not $env->{$var}")
  62             unless ref($env->{$var});
  63     }
  64 }
  65
  66 sub _clean_eval_closure {
  67     # my ($source, $__captures, $name) = @_
  68     my $__captures = $_[1];
  69
  70     local $@;
  71     local $SIG{__DIE__};
  72
  73     if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) {
  74         _dump_source(_make_source(@_), $_[2]);
  75     }
  76
  77     my $code = eval _make_source(@_);
  78     my $e = $@;
  79
  80     if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) {
  81         $e = "The 'source' parameter must return a subroutine reference, "
  82            . "not $code";
  83         undef $code;
  84     }
  85
  86     return ($code, $e);
  87 }
  88
  89 sub _make_source {
  90     my ($source, $__captures) = @_;
  91     return join "\n", (
  92         (map {
  93             'my ' . $_ . ' = '
  94                 . substr($_, 0, 1) . '{$__captures->{\'' . $_ . '\'}};'
  95          } keys %$__captures),
  96         $source,
  97     );
  98 }
  99
 100 sub _dump_source {
 101     my ($source, $name) = @_;
 102
 103     my $output;
 104     if (try { require Perl::Tidy }) {
 105         Perl::Tidy::perltidy(
 106             source      => \$source,
 107             destination => \$output,
 108         );
 109     }
 110     else {
 111         $output = $source;
 112     }
 113
 114     $name = defined($name) ? $name : "__ANON__";
 115     warn $name . ":\n" . $output . "\n";
 116 }
 117
 118 1;