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 | }; |
ed9a00ae |
8 | # ABSTRACT: safely and cleanly create closures via string eval |
efb592ef |
9 | |
10 | use Carp; |
11 | use overload (); |
61717119 |
12 | use Memoize; |
efb592ef |
13 | use Scalar::Util qw(reftype); |
14 | use Try::Tiny; |
15 | |
ed9a00ae |
16 | =head1 SYNOPSIS |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | =cut |
21 | |
22 | =func eval_closure(%args) |
23 | |
24 | =cut |
25 | |
efb592ef |
26 | sub eval_closure { |
27 | my (%args) = @_; |
8e1b3d7b |
28 | |
efb592ef |
29 | $args{source} = _canonicalize_source($args{source}); |
8e1b3d7b |
30 | _validate_env($args{environment} ||= {}); |
efb592ef |
31 | |
3efcc087 |
32 | $args{source} = _line_directive($args{description}) . $args{source} |
33 | if defined $args{description}; |
34 | |
409b8f41 |
35 | my ($code, $e) = _clean_eval_closure(@args{qw(source environment)}); |
efb592ef |
36 | |
37 | croak("Failed to compile source: $e\n\nsource:\n$args{source}") |
38 | unless $code; |
39 | |
40 | return $code; |
41 | } |
42 | |
43 | sub _canonicalize_source { |
44 | my ($source) = @_; |
45 | |
46 | if (defined($source)) { |
47 | if (ref($source)) { |
48 | if (reftype($source) eq 'ARRAY' |
49 | || overload::Method($source, '@{}')) { |
50 | return join "\n", @$source; |
51 | } |
52 | elsif (overload::Method($source, '""')) { |
53 | return "$source"; |
54 | } |
55 | else { |
56 | croak("The 'source' parameter to eval_closure must be a " |
57 | . "string or array reference"); |
58 | } |
59 | } |
60 | else { |
61 | return $source; |
62 | } |
63 | } |
64 | else { |
65 | croak("The 'source' parameter to eval_closure is required"); |
66 | } |
67 | } |
68 | |
8e1b3d7b |
69 | sub _validate_env { |
70 | my ($env) = @_; |
71 | |
72 | croak("The 'environment' parameter must be a hashref") |
73 | unless reftype($env) eq 'HASH'; |
74 | |
75 | for my $var (keys %$env) { |
b3bd5eb8 |
76 | croak("Environment key '$var' should start with \@, \%, or \$") |
8e1b3d7b |
77 | unless $var =~ /^([\@\%\$])/; |
78 | croak("Environment values must be references, not $env->{$var}") |
79 | unless ref($env->{$var}); |
80 | } |
81 | } |
82 | |
3efcc087 |
83 | sub _line_directive { |
84 | my ($description) = @_; |
85 | |
86 | return qq{#line 1 "$description"\n}; |
87 | } |
88 | |
efb592ef |
89 | sub _clean_eval_closure { |
f3c27658 |
90 | my ($source, $captures) = @_; |
efb592ef |
91 | |
a30f41f7 |
92 | if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { |
f3c27658 |
93 | _dump_source(_make_compiler_source(@_)); |
a30f41f7 |
94 | } |
efb592ef |
95 | |
53b0abc5 |
96 | my @capture_keys = sort keys %$captures; |
447800b5 |
97 | my ($compiler, $e) = _make_compiler($source, @capture_keys); |
f3c27658 |
98 | my $code; |
99 | if (defined $compiler) { |
447800b5 |
100 | $code = $compiler->(@$captures{@capture_keys}); |
f3c27658 |
101 | } |
26eb0e7a |
102 | |
b86710e9 |
103 | if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) { |
3eb05ecb |
104 | $e = "The 'source' parameter must return a subroutine reference, " |
105 | . "not $code"; |
26eb0e7a |
106 | undef $code; |
26eb0e7a |
107 | } |
108 | |
18b5b42a |
109 | return ($code, $e); |
efb592ef |
110 | } |
111 | |
f3c27658 |
112 | sub _make_compiler { |
113 | local $@; |
114 | local $SIG{__DIE__}; |
115 | my $compiler = eval _make_compiler_source(@_); |
116 | my $e = $@; |
117 | return ($compiler, $e); |
118 | } |
61717119 |
119 | memoize('_make_compiler'); |
f3c27658 |
120 | |
121 | sub _make_compiler_source { |
447800b5 |
122 | my ($source, @capture_keys) = @_; |
f3c27658 |
123 | my $i = 0; |
efb592ef |
124 | return join "\n", ( |
f3c27658 |
125 | 'sub {', |
efb592ef |
126 | (map { |
f3c27658 |
127 | 'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};' |
447800b5 |
128 | } @capture_keys), |
efb592ef |
129 | $source, |
f3c27658 |
130 | '}', |
efb592ef |
131 | ); |
132 | } |
133 | |
134 | sub _dump_source { |
409b8f41 |
135 | my ($source) = @_; |
efb592ef |
136 | |
137 | my $output; |
138 | if (try { require Perl::Tidy }) { |
139 | Perl::Tidy::perltidy( |
140 | source => \$source, |
141 | destination => \$output, |
142 | ); |
143 | } |
144 | else { |
145 | $output = $source; |
146 | } |
147 | |
409b8f41 |
148 | warn "$output\n"; |
efb592ef |
149 | } |
150 | |
ed9a00ae |
151 | =head1 BUGS |
152 | |
153 | No known bugs. |
154 | |
155 | Please report any bugs through RT: email |
156 | C<bug-eval-closure at rt.cpan.org>, or browse to |
157 | L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Eval-Closure>. |
158 | |
159 | =head1 SEE ALSO |
160 | |
161 | =over 4 |
162 | |
163 | =item * L<Class::MOP::Method::Accessor> |
164 | |
165 | This module is a factoring out of code that used to live here |
166 | |
167 | =back |
168 | |
169 | =head1 SUPPORT |
170 | |
171 | You can find this documentation for this module with the perldoc command. |
172 | |
173 | perldoc Eval::Closure |
174 | |
175 | You can also look for information at: |
176 | |
177 | =over 4 |
178 | |
179 | =item * AnnoCPAN: Annotated CPAN documentation |
180 | |
181 | L<http://annocpan.org/dist/Eval-Closure> |
182 | |
183 | =item * CPAN Ratings |
184 | |
185 | L<http://cpanratings.perl.org/d/Eval-Closure> |
186 | |
187 | =item * RT: CPAN's request tracker |
188 | |
189 | L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Eval-Closure> |
190 | |
191 | =item * Search CPAN |
192 | |
193 | L<http://search.cpan.org/dist/Eval-Closure> |
194 | |
195 | =back |
196 | |
197 | =head1 AUTHOR |
198 | |
199 | Jesse Luehrs <doy at tozt dot net> |
200 | |
201 | Based on code from L<Class::MOP::Method::Accessor>, by Stevan Little and the |
202 | Moose Cabal. |
203 | |
204 | =cut |
205 | |
efb592ef |
206 | 1; |