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