lib/Eval/Closure.pm

   1 package Eval::Closure;
   2 use Sub::Exporter -setup => {
   3     exports => [qw(eval_closure)],
   4 };
   5
   6 use Carp;
   7 use overload ();
   8 use Scalar::Util qw(reftype);
   9 use Try::Tiny;
  10
  11 sub eval_closure {
  12     my (%args) = @_;
  13     $args{source} = _canonicalize_source($args{source});
  14
  15     my ($code, $e) = _clean_eval_closure(@args{qw(source environment name)});
  16
  17     croak("Failed to compile source: $e\n\nsource:\n$args{source}")
  18         unless $code;
  19
  20     return $code;
  21 }
  22
  23 sub _canonicalize_source {
  24     my ($source) = @_;
  25
  26     if (defined($source)) {
  27         if (ref($source)) {
  28             if (reftype($source) eq 'ARRAY'
  29              || overload::Method($source, '@{}')) {
  30                 return join "\n", @$source;
  31             }
  32             elsif (overload::Method($source, '""')) {
  33                 return "$source";
  34             }
  35             else {
  36                 croak("The 'source' parameter to eval_closure must be a "
  37                     . "string or array reference");
  38             }
  39         }
  40         else {
  41             return $source;
  42         }
  43     }
  44     else {
  45         croak("The 'source' parameter to eval_closure is required");
  46     }
  47 }
  48
  49 sub _clean_eval_closure {
  50     # my ($source, $__captures, $name) = @_
  51     my $__captures = $_[1];
  52
  53     do {
  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         ($code, $@);
  63     };
  64 }
  65
  66 sub _make_source {
  67     my ($source, $__captures) = @_;
  68     return join "\n", (
  69         (map {
  70             die "Capture key should start with \@, \% or \$: $_"
  71                 unless /^([\@\%\$])/;
  72             'my ' . $_ . ' = ' . $1 . '{$__captures->{\'' . $_ . '\'}};';
  73         } keys %$__captures),
  74         $source,
  75     );
  76 }
  77
  78 sub _dump_source {
  79     my ($source, $name) = @_;
  80
  81     my $output;
  82     if (try { require Perl::Tidy }) {
  83         Perl::Tidy::perltidy(
  84             source      => \$source,
  85             destination => \$output,
  86         );
  87     }
  88     else {
  89         $output = $source;
  90     }
  91
  92     $name = defined($name) ? $name : "__ANON__";
  93     warn $name . ":\n" . $output . "\n";
  94 }
  95
  96 1;