Filename | /usr/local/lib/perl5/site_perl/Eval/Closure.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN@10 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | BEGIN@13 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | BEGIN@14 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | BEGIN@15 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | BEGIN@17 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | BEGIN@2 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | BEGIN@6 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | BEGIN@7 | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _canonicalize_source | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _clean_eval | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _clean_eval_closure | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _dump_source | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _line_directive | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _make_compiler | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _make_compiler_source | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _make_lexical_assignment | Eval::Closure::
0 | 0 | 0 | 0s | 0s | _validate_env | Eval::Closure::
0 | 0 | 0 | 0s | 0s | eval_closure | Eval::Closure::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Eval::Closure; | ||||
2 | BEGIN { | ||||
3 | $Eval::Closure::AUTHORITY = 'cpan:DOY'; | ||||
4 | } | ||||
5 | $Eval::Closure::VERSION = '0.14'; | ||||
6 | use strict; | ||||
7 | use warnings; | ||||
8 | # ABSTRACT: safely and cleanly create closures via string eval | ||||
9 | |||||
10 | use Exporter 'import'; | ||||
11 | @Eval::Closure::EXPORT = @Eval::Closure::EXPORT_OK = 'eval_closure'; | ||||
12 | |||||
13 | use Carp; | ||||
14 | use overload (); | ||||
15 | use Scalar::Util qw(reftype); | ||||
16 | |||||
17 | use constant HAS_LEXICAL_SUBS => $] >= 5.018; | ||||
18 | |||||
- - | |||||
21 | sub eval_closure { | ||||
22 | my (%args) = @_; | ||||
23 | |||||
24 | # default to copying environment | ||||
25 | $args{alias} = 0 if !exists $args{alias}; | ||||
26 | |||||
27 | $args{source} = _canonicalize_source($args{source}); | ||||
28 | _validate_env($args{environment} ||= {}); | ||||
29 | |||||
30 | $args{source} = _line_directive(@args{qw(line description)}) | ||||
31 | . $args{source} | ||||
32 | if defined $args{description} && !($^P & 0x10); | ||||
33 | |||||
34 | my ($code, $e) = _clean_eval_closure(@args{qw(source environment alias)}); | ||||
35 | |||||
36 | if (!$code) { | ||||
37 | if ($args{terse_error}) { | ||||
38 | die "$e\n"; | ||||
39 | } | ||||
40 | else { | ||||
41 | croak("Failed to compile source: $e\n\nsource:\n$args{source}") | ||||
42 | } | ||||
43 | } | ||||
44 | |||||
45 | return $code; | ||||
46 | } | ||||
47 | |||||
48 | sub _canonicalize_source { | ||||
49 | my ($source) = @_; | ||||
50 | |||||
51 | if (defined($source)) { | ||||
52 | if (ref($source)) { | ||||
53 | if (reftype($source) eq 'ARRAY' | ||||
54 | || overload::Method($source, '@{}')) { | ||||
55 | return join "\n", @$source; | ||||
56 | } | ||||
57 | elsif (overload::Method($source, '""')) { | ||||
58 | return "$source"; | ||||
59 | } | ||||
60 | else { | ||||
61 | croak("The 'source' parameter to eval_closure must be a " | ||||
62 | . "string or array reference"); | ||||
63 | } | ||||
64 | } | ||||
65 | else { | ||||
66 | return $source; | ||||
67 | } | ||||
68 | } | ||||
69 | else { | ||||
70 | croak("The 'source' parameter to eval_closure is required"); | ||||
71 | } | ||||
72 | } | ||||
73 | |||||
74 | sub _validate_env { | ||||
75 | my ($env) = @_; | ||||
76 | |||||
77 | croak("The 'environment' parameter must be a hashref") | ||||
78 | unless reftype($env) eq 'HASH'; | ||||
79 | |||||
80 | for my $var (keys %$env) { | ||||
81 | if (HAS_LEXICAL_SUBS) { | ||||
82 | croak("Environment key '$var' should start with \@, \%, \$, or \&") | ||||
83 | if index('$@%&', substr($var, 0, 1)) < 0; | ||||
84 | } | ||||
85 | else { | ||||
86 | croak("Environment key '$var' should start with \@, \%, or \$") | ||||
87 | if index('$@%', substr($var, 0, 1)) < 0; | ||||
88 | } | ||||
89 | croak("Environment values must be references, not $env->{$var}") | ||||
90 | unless ref($env->{$var}); | ||||
91 | } | ||||
92 | } | ||||
93 | |||||
94 | sub _line_directive { | ||||
95 | my ($line, $description) = @_; | ||||
96 | |||||
97 | $line = 1 unless defined($line); | ||||
98 | |||||
99 | return qq{#line $line "$description"\n}; | ||||
100 | } | ||||
101 | |||||
102 | sub _clean_eval_closure { | ||||
103 | my ($source, $captures, $alias) = @_; | ||||
104 | |||||
105 | my @capture_keys = keys %$captures; | ||||
106 | |||||
107 | if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { | ||||
108 | _dump_source(_make_compiler_source($source, $alias, @capture_keys)); | ||||
109 | } | ||||
110 | |||||
111 | my ($compiler, $e) = _make_compiler($source, $alias, @capture_keys); | ||||
112 | return (undef, $e) unless defined $compiler; | ||||
113 | |||||
114 | my $code = $compiler->(@$captures{@capture_keys}); | ||||
115 | |||||
116 | if (!defined $code) { | ||||
117 | return ( | ||||
118 | undef, | ||||
119 | "The 'source' parameter must return a subroutine reference, " | ||||
120 | . "not undef" | ||||
121 | ) | ||||
122 | } | ||||
123 | if (!ref($code) || ref($code) ne 'CODE') { | ||||
124 | return ( | ||||
125 | undef, | ||||
126 | "The 'source' parameter must return a subroutine reference, not " | ||||
127 | . ref($code) | ||||
128 | ) | ||||
129 | } | ||||
130 | |||||
131 | if ($alias) { | ||||
132 | require Devel::LexAlias; | ||||
133 | Devel::LexAlias::lexalias($code, $_, $captures->{$_}) | ||||
134 | for grep substr($_, 0, 1) ne '&', @capture_keys; | ||||
135 | } | ||||
136 | |||||
137 | return ($code, $e); | ||||
138 | } | ||||
139 | |||||
140 | sub _make_compiler { | ||||
141 | my $source = _make_compiler_source(@_); | ||||
142 | |||||
143 | _clean_eval($source) | ||||
144 | } | ||||
145 | |||||
146 | sub _clean_eval { | ||||
147 | local $@; | ||||
148 | local $SIG{__DIE__}; | ||||
149 | my $compiler = eval $_[0]; # spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval
# spent 0s executing statements in string eval | ||||
150 | my $e = $@; | ||||
151 | ( $compiler, $e ) | ||||
152 | } | ||||
153 | |||||
154 | $Eval::Closure::SANDBOX_ID = 0; | ||||
155 | |||||
156 | sub _make_compiler_source { | ||||
157 | my ($source, $alias, @capture_keys) = @_; | ||||
158 | $Eval::Closure::SANDBOX_ID++; | ||||
159 | my $i = 0; | ||||
160 | return join "\n", ( | ||||
161 | "package Eval::Closure::Sandbox_$Eval::Closure::SANDBOX_ID;", | ||||
162 | 'sub {', | ||||
163 | (map { _make_lexical_assignment($_, $i++, $alias) } @capture_keys), | ||||
164 | $source, | ||||
165 | '}', | ||||
166 | ); | ||||
167 | } | ||||
168 | |||||
169 | sub _make_lexical_assignment { | ||||
170 | my ($key, $index, $alias) = @_; | ||||
171 | my $sigil = substr($key, 0, 1); | ||||
172 | my $name = substr($key, 1); | ||||
173 | if (HAS_LEXICAL_SUBS && $sigil eq '&') { | ||||
174 | my $tmpname = '$__' . $name . '__' . $index; | ||||
175 | return 'use feature "lexical_subs"; ' | ||||
176 | . 'no warnings "experimental::lexical_subs"; ' | ||||
177 | . 'my ' . $tmpname . ' = $_[' . $index . ']; ' | ||||
178 | . 'my sub ' . $name . ' { goto ' . $tmpname . ' }'; | ||||
179 | } | ||||
180 | if ($alias) { | ||||
181 | return 'my ' . $key . ';'; | ||||
182 | } | ||||
183 | else { | ||||
184 | return 'my ' . $key . ' = ' . $sigil . '{$_[' . $index . ']};'; | ||||
185 | } | ||||
186 | } | ||||
187 | |||||
188 | sub _dump_source { | ||||
189 | my ($source) = @_; | ||||
190 | |||||
191 | my $output; | ||||
192 | local $@; | ||||
193 | if (eval { require Perl::Tidy; 1 }) { | ||||
194 | Perl::Tidy::perltidy( | ||||
195 | source => \$source, | ||||
196 | destination => \$output, | ||||
197 | argv => [], | ||||
198 | ); | ||||
199 | } | ||||
200 | else { | ||||
201 | $output = $source; | ||||
202 | } | ||||
203 | |||||
204 | warn "$output\n"; | ||||
205 | } | ||||
206 | |||||
207 | |||||
208 | 1; | ||||
209 | |||||
210 | __END__ |