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