Commit | Line | Data |
efb592ef |
1 | package Eval::Closure; |
b3bd5eb8 |
2 | use strict; |
3 | use warnings; |
efb592ef |
4 | use Sub::Exporter -setup => { |
5 | exports => [qw(eval_closure)], |
ce19c70b |
6 | groups => { default => [qw(eval_closure)] }, |
efb592ef |
7 | }; |
8 | |
9 | use Carp; |
10 | use overload (); |
61717119 |
11 | use Memoize; |
efb592ef |
12 | use Scalar::Util qw(reftype); |
13 | use Try::Tiny; |
14 | |
15 | sub eval_closure { |
16 | my (%args) = @_; |
8e1b3d7b |
17 | |
efb592ef |
18 | $args{source} = _canonicalize_source($args{source}); |
8e1b3d7b |
19 | _validate_env($args{environment} ||= {}); |
efb592ef |
20 | |
3efcc087 |
21 | $args{source} = _line_directive($args{description}) . $args{source} |
22 | if defined $args{description}; |
23 | |
409b8f41 |
24 | my ($code, $e) = _clean_eval_closure(@args{qw(source environment)}); |
efb592ef |
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 | |
8e1b3d7b |
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) { |
b3bd5eb8 |
65 | croak("Environment key '$var' should start with \@, \%, or \$") |
8e1b3d7b |
66 | unless $var =~ /^([\@\%\$])/; |
67 | croak("Environment values must be references, not $env->{$var}") |
68 | unless ref($env->{$var}); |
69 | } |
70 | } |
71 | |
3efcc087 |
72 | sub _line_directive { |
73 | my ($description) = @_; |
74 | |
75 | return qq{#line 1 "$description"\n}; |
76 | } |
77 | |
efb592ef |
78 | sub _clean_eval_closure { |
f3c27658 |
79 | my ($source, $captures) = @_; |
efb592ef |
80 | |
a30f41f7 |
81 | if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { |
f3c27658 |
82 | _dump_source(_make_compiler_source(@_)); |
a30f41f7 |
83 | } |
efb592ef |
84 | |
447800b5 |
85 | my @capture_keys = keys %$captures; |
86 | my ($compiler, $e) = _make_compiler($source, @capture_keys); |
f3c27658 |
87 | my $code; |
88 | if (defined $compiler) { |
447800b5 |
89 | $code = $compiler->(@$captures{@capture_keys}); |
f3c27658 |
90 | } |
26eb0e7a |
91 | |
b86710e9 |
92 | if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) { |
3eb05ecb |
93 | $e = "The 'source' parameter must return a subroutine reference, " |
94 | . "not $code"; |
26eb0e7a |
95 | undef $code; |
26eb0e7a |
96 | } |
97 | |
18b5b42a |
98 | return ($code, $e); |
efb592ef |
99 | } |
100 | |
f3c27658 |
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 | } |
61717119 |
108 | memoize('_make_compiler'); |
f3c27658 |
109 | |
110 | sub _make_compiler_source { |
447800b5 |
111 | my ($source, @capture_keys) = @_; |
f3c27658 |
112 | my $i = 0; |
efb592ef |
113 | return join "\n", ( |
f3c27658 |
114 | 'sub {', |
efb592ef |
115 | (map { |
f3c27658 |
116 | 'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};' |
447800b5 |
117 | } @capture_keys), |
efb592ef |
118 | $source, |
f3c27658 |
119 | '}', |
efb592ef |
120 | ); |
121 | } |
122 | |
123 | sub _dump_source { |
409b8f41 |
124 | my ($source) = @_; |
efb592ef |
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 | |
409b8f41 |
137 | warn "$output\n"; |
efb592ef |
138 | } |
139 | |
140 | 1; |