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