Filename | /opt/perl-5.18.1/lib/site_perl/5.18.1/Sub/Quote.pm |
Statements | Executed 174 statements in 1.98ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
3 | 1 | 1 | 1.28ms | 1.37ms | _clean_eval | Sub::Quote::
3 | 1 | 1 | 221µs | 234µs | capture_unroll | Sub::Quote::
6 | 3 | 3 | 95µs | 201µs | quote_sub | Sub::Quote::
3 | 1 | 1 | 86µs | 1.69ms | unquote_sub | Sub::Quote::
1 | 1 | 1 | 22µs | 79µs | BEGIN@3 | Sub::Quote::
2 | 1 | 1 | 19µs | 21µs | inlinify | Sub::Quote::
1 | 1 | 1 | 12µs | 48µs | BEGIN@7 | Sub::Quote::
4 | 1 | 1 | 10µs | 10µs | quoted_from_sub | Sub::Quote::
1 | 1 | 1 | 9µs | 24µs | BEGIN@108 | Sub::Quote::
1 | 1 | 1 | 9µs | 36µs | BEGIN@8 | Sub::Quote::
1 | 1 | 1 | 9µs | 36µs | BEGIN@9 | Sub::Quote::
1 | 1 | 1 | 9µs | 82µs | BEGIN@10 | Sub::Quote::
6 | 2 | 1 | 8µs | 8µs | CORE:match (opcode) | Sub::Quote::
0 | 0 | 0 | 0s | 0s | CLONE | Sub::Quote::
0 | 0 | 0 | 0s | 0s | __ANON__[:69] | Sub::Quote::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Sub::Quote; | ||||
2 | |||||
3 | 3 | 68µs | 3 | 135µs | # spent 79µs (22+57) within Sub::Quote::BEGIN@3 which was called:
# once (22µs+57µs) by Foo::Moo::QS::BEGIN@130 at line 3 # spent 79µs making 1 call to Sub::Quote::BEGIN@3
# spent 40µs making 1 call to strictures::import
# spent 16µs making 1 call to strictures::VERSION |
4 | |||||
5 | 3 | 289µs | # spent 1.37ms (1.28+90µs) within Sub::Quote::_clean_eval which was called 3 times, avg 458µs/call:
# 3 times (1.28ms+90µs) by Sub::Quote::unquote_sub at line 110, avg 458µs/call # spent 368µs executing statements in string eval # includes 32µs spent executing 3 calls to 2 subs defined therein. # spent 358µs executing statements in string eval # includes 47µs spent executing 4 calls to 2 subs defined therein. # spent 347µs executing statements in string eval # includes 30µs spent executing 3 calls to 2 subs defined therein. | ||
6 | |||||
7 | 2 | 45µs | 2 | 83µs | # spent 48µs (12+35) within Sub::Quote::BEGIN@7 which was called:
# once (12µs+35µs) by Foo::Moo::QS::BEGIN@130 at line 7 # spent 48µs making 1 call to Sub::Quote::BEGIN@7
# spent 35µs making 1 call to Exporter::import |
8 | 2 | 33µs | 2 | 64µs | # spent 36µs (9+27) within Sub::Quote::BEGIN@8 which was called:
# once (9µs+27µs) by Foo::Moo::QS::BEGIN@130 at line 8 # spent 36µs making 1 call to Sub::Quote::BEGIN@8
# spent 28µs making 1 call to Exporter::import |
9 | 2 | 33µs | 2 | 63µs | # spent 36µs (9+27) within Sub::Quote::BEGIN@9 which was called:
# once (9µs+27µs) by Foo::Moo::QS::BEGIN@130 at line 9 # spent 36µs making 1 call to Sub::Quote::BEGIN@9
# spent 27µs making 1 call to Exporter::import |
10 | 2 | 767µs | 2 | 156µs | # spent 82µs (9+74) within Sub::Quote::BEGIN@10 which was called:
# once (9µs+74µs) by Foo::Moo::QS::BEGIN@130 at line 10 # spent 82µs making 1 call to Sub::Quote::BEGIN@10
# spent 74µs making 1 call to base::import |
11 | |||||
12 | 1 | 800ns | our $VERSION = '1.003001'; | ||
13 | 1 | 15µs | $VERSION = eval $VERSION; # spent 3µs executing statements in string eval | ||
14 | |||||
15 | 1 | 1µs | our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); | ||
16 | |||||
17 | 1 | 200ns | our %QUOTED; | ||
18 | |||||
19 | 1 | 0s | our %WEAK_REFS; | ||
20 | |||||
21 | # spent 234µs (221+13) within Sub::Quote::capture_unroll which was called 3 times, avg 78µs/call:
# 3 times (221µs+13µs) by Sub::Quote::unquote_sub at line 89, avg 78µs/call | ||||
22 | 3 | 1µs | my ($from, $captures, $indent) = @_; | ||
23 | 4 | 184µs | 4 | 7µs | join( # spent 7µs making 4 calls to Sub::Quote::CORE:match, avg 2µs/call |
24 | '', | ||||
25 | map { | ||||
26 | 3 | 19µs | /^([\@\%\$])/ | ||
27 | or die "capture key should start with \@, \% or \$: $_"; | ||||
28 | 8 | 32µs | 4 | 6µs | (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n}; # spent 6µs making 4 calls to B::perlstring, avg 2µs/call |
29 | } keys %$captures | ||||
30 | ); | ||||
31 | } | ||||
32 | |||||
33 | # spent 21µs (19+2) within Sub::Quote::inlinify which was called 2 times, avg 10µs/call:
# 2 times (19µs+2µs) by Method::Generate::Accessor::_generate_call_code at line 442 of Method/Generate/Accessor.pm, avg 10µs/call | ||||
34 | 2 | 1µs | my ($code, $args, $extra, $local) = @_; | ||
35 | 2 | 2µs | my $do = 'do { '.($extra||''); | ||
36 | 2 | 14µs | 2 | 2µs | if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) { # spent 2µs making 2 calls to Sub::Quote::CORE:match, avg 900ns/call |
37 | if ($code_args eq $args) { | ||||
38 | $do.$body.' }' | ||||
39 | } else { | ||||
40 | $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }'; | ||||
41 | } | ||||
42 | } else { | ||||
43 | 2 | 900ns | my $assign = ''; | ||
44 | 2 | 2µs | if ($local || $args ne '@_') { | ||
45 | $assign = ($local ? 'local ' : '').'@_ = ('.$args.'); '; | ||||
46 | } | ||||
47 | 2 | 2µs | $do.$assign.$code.' }'; | ||
48 | } | ||||
49 | } | ||||
50 | |||||
51 | # spent 201µs (95+106) within Sub::Quote::quote_sub which was called 6 times, avg 34µs/call:
# 3 times (52µs+34µs) by Method::Generate::Constructor::generate_method at line 98 of Method/Generate/Constructor.pm, avg 28µs/call
# 2 times (30µs+60µs) by Method::Generate::Accessor::generate_method at line 132 of Method/Generate/Accessor.pm, avg 45µs/call
# once (13µs+12µs) by main::RUNTIME at line 131 of fastest.pl | ||||
52 | # HOLY DWIMMERY, BATMAN! | ||||
53 | # $name => $code => \%captures => \%options | ||||
54 | # $name => $code => \%captures | ||||
55 | # $name => $code | ||||
56 | # $code => \%captures => \%options | ||||
57 | # $code | ||||
58 | 6 | 8µs | my $options = | ||
59 | (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH') | ||||
60 | ? pop | ||||
61 | : {}; | ||||
62 | 6 | 2µs | my $captures = pop if ref($_[-1]) eq 'HASH'; | ||
63 | 6 | 5µs | undef($captures) if $captures && !keys %$captures; | ||
64 | 6 | 2µs | my $code = pop; | ||
65 | 6 | 2µs | my $name = $_[0]; | ||
66 | 6 | 600ns | my $quoted_info; | ||
67 | my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub { | ||||
68 | unquote_sub($quoted_info->[4]); | ||||
69 | 6 | 26µs | 6 | 101µs | }; # spent 101µs making 6 calls to Sub::Defer::defer_sub, avg 17µs/call |
70 | 6 | 8µs | $quoted_info = [ $name, $code, $captures, undef, $deferred ]; | ||
71 | 6 | 23µs | 6 | 4µs | weaken($QUOTED{$deferred} = $quoted_info); # spent 4µs making 6 calls to Scalar::Util::weaken, avg 750ns/call |
72 | 6 | 21µs | return $deferred; | ||
73 | } | ||||
74 | |||||
75 | # spent 10µs within Sub::Quote::quoted_from_sub which was called 4 times, avg 2µs/call:
# 4 times (10µs+0s) by Method::Generate::Accessor::_generate_call_code at line 428 of Method/Generate/Accessor.pm, avg 2µs/call | ||||
76 | 4 | 1µs | my ($sub) = @_; | ||
77 | 4 | 13µs | $QUOTED{$sub||''}; | ||
78 | } | ||||
79 | |||||
80 | # spent 1.69ms (86µs+1.61) within Sub::Quote::unquote_sub which was called 3 times, avg 565µs/call:
# 3 times (86µs+1.61ms) by Method::Generate::Constructor::__ANON__[/opt/perl-5.18.1/lib/site_perl/5.18.1/Method/Generate/Constructor.pm:64] at line 61 of Method/Generate/Constructor.pm, avg 565µs/call | ||||
81 | 3 | 1µs | my ($sub) = @_; | ||
82 | 3 | 6µs | unless ($QUOTED{$sub}[3]) { | ||
83 | 3 | 7µs | my ($name, $code, $captures) = @{$QUOTED{$sub}}; | ||
84 | |||||
85 | 3 | 1µs | my $make_sub = "{\n"; | ||
86 | |||||
87 | 3 | 3µs | my %captures = $captures ? %$captures : (); | ||
88 | 3 | 4µs | $captures{'$_QUOTED'} = \$QUOTED{$sub}; | ||
89 | 3 | 6µs | 3 | 234µs | $make_sub .= capture_unroll("\$_[1]", \%captures, 2); # spent 234µs making 3 calls to Sub::Quote::capture_unroll, avg 78µs/call |
90 | |||||
91 | 3 | 3µs | $make_sub .= ( | ||
92 | $name | ||||
93 | # disable the 'variable $x will not stay shared' warning since | ||||
94 | # we're not letting it escape from this scope anyway so there's | ||||
95 | # nothing trying to share it | ||||
96 | ? " no warnings 'closure';\n sub ${name} {\n" | ||||
97 | : " \$_QUOTED->[3] = sub {\n" | ||||
98 | ); | ||||
99 | 3 | 1µs | $make_sub .= $code; | ||
100 | 3 | 2µs | $make_sub .= " }".($name ? '' : ';')."\n"; | ||
101 | 3 | 2µs | if ($name) { | ||
102 | $make_sub .= " \$_QUOTED->[3] = \\&${name}\n"; | ||||
103 | } | ||||
104 | 3 | 600ns | $make_sub .= "}\n1;\n"; | ||
105 | 3 | 2µs | $ENV{SUB_QUOTE_DEBUG} && warn $make_sub; | ||
106 | { | ||||
107 | 6 | 4µs | local $@; | ||
108 | 2 | 283µs | 2 | 38µs | # spent 24µs (9+15) within Sub::Quote::BEGIN@108 which was called:
# once (9µs+15µs) by Foo::Moo::QS::BEGIN@130 at line 108 # spent 24µs making 1 call to Sub::Quote::BEGIN@108
# spent 15µs making 1 call to strict::unimport |
109 | 3 | 7µs | local *{$name} if $name; | ||
110 | 3 | 8µs | 3 | 1.37ms | unless (_clean_eval $make_sub, \%captures) { # spent 1.37ms making 3 calls to Sub::Quote::_clean_eval, avg 458µs/call |
111 | die "Eval went very, very wrong:\n\n${make_sub}\n\n$@"; | ||||
112 | } | ||||
113 | } | ||||
114 | } | ||||
115 | 3 | 14µs | $QUOTED{$sub}[3]; | ||
116 | } | ||||
117 | |||||
118 | sub CLONE { | ||||
119 | %QUOTED = map { defined $_ ? ($_->[4] => $_) : () } values %QUOTED; | ||||
120 | weaken($_) for values %QUOTED; | ||||
121 | } | ||||
122 | |||||
123 | 1 | 5µs | 1; | ||
124 | |||||
125 | =head1 NAME | ||||
126 | |||||
127 | Sub::Quote - efficient generation of subroutines via string eval | ||||
128 | |||||
129 | =head1 SYNOPSIS | ||||
130 | |||||
131 | package Silly; | ||||
132 | |||||
133 | use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub); | ||||
134 | |||||
135 | quote_sub 'Silly::kitty', q{ print "meow" }; | ||||
136 | |||||
137 | quote_sub 'Silly::doggy', q{ print "woof" }; | ||||
138 | |||||
139 | my $sound = 0; | ||||
140 | |||||
141 | quote_sub 'Silly::dagron', | ||||
142 | q{ print ++$sound % 2 ? 'burninate' : 'roar' }, | ||||
143 | { '$sound' => \$sound }; | ||||
144 | |||||
145 | And elsewhere: | ||||
146 | |||||
147 | Silly->kitty; # meow | ||||
148 | Silly->doggy; # woof | ||||
149 | Silly->dagron; # burninate | ||||
150 | Silly->dagron; # roar | ||||
151 | Silly->dagron; # burninate | ||||
152 | |||||
153 | =head1 DESCRIPTION | ||||
154 | |||||
155 | This package provides performant ways to generate subroutines from strings. | ||||
156 | |||||
157 | =head1 SUBROUTINES | ||||
158 | |||||
159 | =head2 quote_sub | ||||
160 | |||||
161 | my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 }; | ||||
162 | |||||
163 | Arguments: ?$name, $code, ?\%captures, ?\%options | ||||
164 | |||||
165 | C<$name> is the subroutine where the coderef will be installed. | ||||
166 | |||||
167 | C<$code> is a string that will be turned into code. | ||||
168 | |||||
169 | C<\%captures> is a hashref of variables that will be made available to the | ||||
170 | code. The keys should be the full name of the variable to be made available, | ||||
171 | including the sigil. The values should be references to the values. The | ||||
172 | variables will contain copies of the values. See the L</SYNOPSIS>'s | ||||
173 | C<Silly::dagron> for an example using captures. | ||||
174 | |||||
175 | =head3 options | ||||
176 | |||||
177 | =over 2 | ||||
178 | |||||
179 | =item * no_install | ||||
180 | |||||
181 | B<Boolean>. Set this option to not install the generated coderef into the | ||||
182 | passed subroutine name on undefer. | ||||
183 | |||||
184 | =back | ||||
185 | |||||
186 | =head2 unquote_sub | ||||
187 | |||||
188 | my $coderef = unquote_sub $sub; | ||||
189 | |||||
190 | Forcibly replace subroutine with actual code. | ||||
191 | |||||
192 | If $sub is not a quoted sub, this is a no-op. | ||||
193 | |||||
194 | =head2 quoted_from_sub | ||||
195 | |||||
196 | my $data = quoted_from_sub $sub; | ||||
197 | |||||
198 | my ($name, $code, $captures, $compiled_sub) = @$data; | ||||
199 | |||||
200 | Returns original arguments to quote_sub, plus the compiled version if this | ||||
201 | sub has already been unquoted. | ||||
202 | |||||
203 | Note that $sub can be either the original quoted version or the compiled | ||||
204 | version for convenience. | ||||
205 | |||||
206 | =head2 inlinify | ||||
207 | |||||
208 | my $prelude = capture_unroll '$captures', { | ||||
209 | '$x' => 1, | ||||
210 | '$y' => 2, | ||||
211 | }; | ||||
212 | |||||
213 | my $inlined_code = inlinify q{ | ||||
214 | my ($x, $y) = @_; | ||||
215 | |||||
216 | print $x + $y . "\n"; | ||||
217 | }, '$x, $y', $prelude; | ||||
218 | |||||
219 | Takes a string of code, a string of arguments, a string of code which acts as a | ||||
220 | "prelude", and a B<Boolean> representing whether or not to localize the | ||||
221 | arguments. | ||||
222 | |||||
223 | =head2 capture_unroll | ||||
224 | |||||
225 | my $prelude = capture_unroll '$captures', { | ||||
226 | '$x' => 1, | ||||
227 | '$y' => 2, | ||||
228 | }, 4; | ||||
229 | |||||
230 | Arguments: $from, \%captures, $indent | ||||
231 | |||||
232 | Generates a snippet of code which is suitable to be used as a prelude for | ||||
233 | L</inlinify>. C<$from> is a string will be used as a hashref in the resulting | ||||
234 | code. The keys of C<%captures> are the names of the variables and the values | ||||
235 | are ignored. C<$indent> is the number of spaces to indent the result by. | ||||
236 | |||||
237 | =head1 CAVEATS | ||||
238 | |||||
239 | Much of this is just string-based code-generation, and as a result, a few caveats | ||||
240 | apply. | ||||
241 | |||||
242 | =head2 return | ||||
243 | |||||
244 | Calling C<return> from a quote_sub'ed sub will not likely do what you intend. | ||||
245 | Instead of returning from the code you defined in C<quote_sub>, it will return | ||||
246 | from the overall function it is composited into. | ||||
247 | |||||
248 | So when you pass in: | ||||
249 | |||||
250 | quote_sub q{ return 1 if $condition; $morecode } | ||||
251 | |||||
252 | It might turn up in the intended context as follows: | ||||
253 | |||||
254 | sub foo { | ||||
255 | |||||
256 | <important code a> | ||||
257 | do { | ||||
258 | return 1 if $condition; | ||||
259 | $morecode | ||||
260 | }; | ||||
261 | <important code b> | ||||
262 | |||||
263 | } | ||||
264 | |||||
265 | Which will obviously return from foo, when all you meant to do was return from | ||||
266 | the code context in quote_sub and proceed with running important code b. | ||||
267 | |||||
268 | =head2 strictures | ||||
269 | |||||
270 | Sub::Quote compiles quoted subs in an environment where C<< use strictures >> | ||||
271 | is in effect. L<strictures> enables L<strict> and FATAL L<warnings>. | ||||
272 | |||||
273 | The following dies I<< Use of uninitialized value in print... >> | ||||
274 | |||||
275 | no warnings; | ||||
276 | quote_sub 'Silly::kitty', q{ print undef }; | ||||
277 | |||||
278 | If you need to disable parts of strictures, do it within the quoted sub: | ||||
279 | |||||
280 | quote_sub 'Silly::kitty', q{ no warnings; print undef }; | ||||
281 | |||||
282 | =head1 SUPPORT | ||||
283 | |||||
284 | See L<Moo> for support and contact information. | ||||
285 | |||||
286 | =head1 AUTHORS | ||||
287 | |||||
288 | See L<Moo> for authors. | ||||
289 | |||||
290 | =head1 COPYRIGHT AND LICENSE | ||||
291 | |||||
292 | See L<Moo> for the copyright and license. | ||||
sub Sub::Quote::CORE:match; # opcode |