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