← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:05 2021

Filename/usr/local/lib/perl5/site_perl/Eval/Closure.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sEval::Closure::::BEGIN@10Eval::Closure::BEGIN@10
0000s0sEval::Closure::::BEGIN@13Eval::Closure::BEGIN@13
0000s0sEval::Closure::::BEGIN@14Eval::Closure::BEGIN@14
0000s0sEval::Closure::::BEGIN@15Eval::Closure::BEGIN@15
0000s0sEval::Closure::::BEGIN@17Eval::Closure::BEGIN@17
0000s0sEval::Closure::::BEGIN@2Eval::Closure::BEGIN@2
0000s0sEval::Closure::::BEGIN@6Eval::Closure::BEGIN@6
0000s0sEval::Closure::::BEGIN@7Eval::Closure::BEGIN@7
0000s0sEval::Closure::::_canonicalize_sourceEval::Closure::_canonicalize_source
0000s0sEval::Closure::::_clean_evalEval::Closure::_clean_eval
0000s0sEval::Closure::::_clean_eval_closureEval::Closure::_clean_eval_closure
0000s0sEval::Closure::::_dump_sourceEval::Closure::_dump_source
0000s0sEval::Closure::::_line_directiveEval::Closure::_line_directive
0000s0sEval::Closure::::_make_compilerEval::Closure::_make_compiler
0000s0sEval::Closure::::_make_compiler_sourceEval::Closure::_make_compiler_source
0000s0sEval::Closure::::_make_lexical_assignmentEval::Closure::_make_lexical_assignment
0000s0sEval::Closure::::_validate_envEval::Closure::_validate_env
0000s0sEval::Closure::::eval_closureEval::Closure::eval_closure
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Eval::Closure;
2BEGIN {
3 $Eval::Closure::AUTHORITY = 'cpan:DOY';
4}
5$Eval::Closure::VERSION = '0.14';
6use strict;
7use warnings;
8# ABSTRACT: safely and cleanly create closures via string eval
9
10use Exporter 'import';
11@Eval::Closure::EXPORT = @Eval::Closure::EXPORT_OK = 'eval_closure';
12
13use Carp;
14use overload ();
15use Scalar::Util qw(reftype);
16
17use constant HAS_LEXICAL_SUBS => $] >= 5.018;
18
- -
21sub 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
48sub _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
74sub _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
94sub _line_directive {
95 my ($line, $description) = @_;
96
97 $line = 1 unless defined($line);
98
99 return qq{#line $line "$description"\n};
100}
101
102sub _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
140sub _make_compiler {
141 my $source = _make_compiler_source(@_);
142
143 _clean_eval($source)
144}
145
146sub _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
156sub _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
169sub _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
188sub _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
2081;
209
210__END__