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     $args{source} = _canonicalize_source($args{source});
  15
  16     my ($code, $e) = _clean_eval_closure(@args{qw(source environment name)});
  17
  18     croak("Failed to compile source: $e\n\nsource:\n$args{source}")
  19         unless $code;
  20
  21     return $code;
  22 }
  23
  24 sub _canonicalize_source {
  25     my ($source) = @_;
  26
  27     if (defined($source)) {
  28         if (ref($source)) {
  29             if (reftype($source) eq 'ARRAY'
  30              || overload::Method($source, '@{}')) {
  31                 return join "\n", @$source;
  32             }
  33             elsif (overload::Method($source, '""')) {
  34                 return "$source";
  35             }
  36             else {
  37                 croak("The 'source' parameter to eval_closure must be a "
  38                     . "string or array reference");
  39             }
  40         }
  41         else {
  42             return $source;
  43         }
  44     }
  45     else {
  46         croak("The 'source' parameter to eval_closure is required");
  47     }
  48 }
  49
  50 sub _clean_eval_closure {
  51     # my ($source, $__captures, $name) = @_
  52     my $__captures = $_[1];
  53
  54     local $@;
  55     local $SIG{__DIE__};
  56
  57     if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) {
  58         _dump_source(_make_source(@_), $_[2]);
  59     }
  60
  61     my $code = eval _make_source(@_);
  62     my $e = $@;
  63
  64     if (!ref($code) || ref($code) ne 'CODE') {
  65         undef $code;
  66         $e = "The 'source' parameter must return a subroutine reference";
  67     }
  68
  69     return ($code, $e);
  70 }
  71
  72 sub _make_source {
  73     my ($source, $__captures) = @_;
  74     return join "\n", (
  75         (map {
  76             die "Capture key should start with \@, \% or \$: $_"
  77                 unless /^([\@\%\$])/;
  78             'my ' . $_ . ' = ' . $1 . '{$__captures->{\'' . $_ . '\'}};';
  79         } keys %$__captures),
  80         $source,
  81     );
  82 }
  83
  84 sub _dump_source {
  85     my ($source, $name) = @_;
  86
  87     my $output;
  88     if (try { require Perl::Tidy }) {
  89         Perl::Tidy::perltidy(
  90             source      => \$source,
  91             destination => \$output,
  92         );
  93     }
  94     else {
  95         $output = $source;
  96     }
  97
  98     $name = defined($name) ? $name : "__ANON__";
  99     warn $name . ":\n" . $output . "\n";
 100 }
 101
 102 1;