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
  63     if (!ref($code) || ref($code) ne 'CODE') {
  64         undef $code;
  65         $@ = "The 'source' parameter must return a subroutine reference";
  66     }
  67
  68     return ($code, $@);
  69 }
  70
  71 sub _make_source {
  72     my ($source, $__captures) = @_;
  73     return join "\n", (
  74         (map {
  75             die "Capture key should start with \@, \% or \$: $_"
  76                 unless /^([\@\%\$])/;
  77             'my ' . $_ . ' = ' . $1 . '{$__captures->{\'' . $_ . '\'}};';
  78         } keys %$__captures),
  79         $source,
  80     );
  81 }
  82
  83 sub _dump_source {
  84     my ($source, $name) = @_;
  85
  86     my $output;
  87     if (try { require Perl::Tidy }) {
  88         Perl::Tidy::perltidy(
  89             source      => \$source,
  90             destination => \$output,
  91         );
  92     }
  93     else {
  94         $output = $source;
  95     }
  96
  97     $name = defined($name) ? $name : "__ANON__";
  98     warn $name . ":\n" . $output . "\n";
  99 }
 100
 101 1;