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 | |
625d6219 |
12 | our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); |
a165a07f |
13 | |
14 | our %QUOTE_OUTSTANDING; |
15 | |
16 | our %QUOTED; |
17 | |
8a0ad775 |
18 | our %WEAK_REFS; |
19 | |
8c6626cf |
20 | sub capture_unroll { |
21 | my ($from, $captures, $indent) = @_; |
22 | join( |
23 | '', |
24 | map { |
25 | /^([\@\%\$])/ |
17a8e3f0 |
26 | or die "capture key should start with \@, \% or \$: $_"; |
8c6626cf |
27 | (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n}; |
28 | } keys %$captures |
29 | ); |
30 | } |
31 | |
e57f338d |
32 | sub inlinify { |
33 | my ($code, $args, $extra, $local) = @_; |
34 | my $do = 'do { '.($extra||''); |
35 | if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) { |
36 | if ($code_args eq $args) { |
37 | $do.$body.' }' |
38 | } else { |
f537c364 |
39 | $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }'; |
e57f338d |
40 | } |
41 | } else { |
42 | $do.($local ? 'local ' : '').'@_ = ('.$args.'); '.$code.' }'; |
43 | } |
44 | } |
45 | |
a165a07f |
46 | sub _unquote_all_outstanding { |
47 | return unless %QUOTE_OUTSTANDING; |
48 | my ($assembled_code, @assembled_captures, @localize_these) = ''; |
6d377074 |
49 | # we sort the keys in order to make debugging more predictable |
50 | foreach my $outstanding (sort keys %QUOTE_OUTSTANDING) { |
a165a07f |
51 | my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}}; |
52 | |
53 | push @localize_these, $name if $name; |
54 | |
55 | my $make_sub = "{\n"; |
56 | |
57 | if (keys %$captures) { |
58 | my $ass_cap_count = @assembled_captures; |
8c6626cf |
59 | $make_sub .= capture_unroll("\$_[1][${ass_cap_count}]", $captures, 2); |
a165a07f |
60 | push @assembled_captures, $captures; |
61 | } |
62 | |
63 | my $o_quoted = perlstring $outstanding; |
64 | $make_sub .= ( |
65 | $name |
934ea2c1 |
66 | # disable the 'variable $x will not stay shared' warning since |
67 | # we're not letting it escape from this scope anyway so there's |
68 | # nothing trying to share it |
a165a07f |
69 | ? " no warnings 'closure';\n sub ${name} {\n" |
934ea2c1 |
70 | : " \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n" |
a165a07f |
71 | ); |
72 | $make_sub .= $code; |
73 | $make_sub .= " }".($name ? '' : ';')."\n"; |
74 | if ($name) { |
75 | $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; |
76 | } |
77 | $make_sub .= "}\n"; |
78 | $assembled_code .= $make_sub; |
79 | } |
a16d301e |
80 | my $debug_code = $assembled_code; |
a165a07f |
81 | if (@localize_these) { |
a16d301e |
82 | $debug_code = |
e8b2bab6 |
83 | "# localizing: ".join(', ', @localize_these)."\n" |
84 | .$assembled_code; |
a165a07f |
85 | $assembled_code = join("\n", |
86 | (map { "local *${_};" } @localize_these), |
a16d301e |
87 | 'eval '.perlstring($assembled_code).'; die $@ if $@;' |
a165a07f |
88 | ); |
e8b2bab6 |
89 | } else { |
90 | $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code; |
a165a07f |
91 | } |
a16d301e |
92 | $assembled_code .= "\n1;"; |
59812c87 |
93 | { |
94 | local $@; |
95 | unless (_clean_eval $assembled_code, \@assembled_captures) { |
96 | die "Eval went very, very wrong:\n\n${debug_code}\n\n$@"; |
97 | } |
a165a07f |
98 | } |
a16d301e |
99 | $ENV{SUB_QUOTE_DEBUG} && warn $debug_code; |
a165a07f |
100 | %QUOTE_OUTSTANDING = (); |
101 | } |
102 | |
103 | sub quote_sub { |
104 | # HOLY DWIMMERY, BATMAN! |
6f68f022 |
105 | # $name => $code => \%captures => \%options |
a165a07f |
106 | # $name => $code => \%captures |
107 | # $name => $code |
6f68f022 |
108 | # $code => \%captures => \%options |
a165a07f |
109 | # $code |
6f68f022 |
110 | my $options = |
111 | (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH') |
112 | ? pop |
113 | : {}; |
a165a07f |
114 | my $captures = pop if ref($_[-1]) eq 'HASH'; |
625d6219 |
115 | undef($captures) if $captures && !keys %$captures; |
a165a07f |
116 | my $code = pop; |
117 | my $name = $_[0]; |
118 | my $outstanding; |
6f68f022 |
119 | my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub { |
a165a07f |
120 | unquote_sub($outstanding); |
121 | }; |
122 | $outstanding = "$deferred"; |
123 | $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [ |
124 | $name, $code, $captures |
125 | ]; |
8a0ad775 |
126 | weaken($WEAK_REFS{$outstanding} = $deferred); |
a165a07f |
127 | return $deferred; |
128 | } |
129 | |
130 | sub quoted_from_sub { |
131 | my ($sub) = @_; |
8a0ad775 |
132 | $WEAK_REFS{$sub||''} and $QUOTED{$sub||''}; |
a165a07f |
133 | } |
134 | |
135 | sub unquote_sub { |
136 | my ($sub) = @_; |
137 | _unquote_all_outstanding; |
138 | $QUOTED{$sub}[3]; |
139 | } |
140 | |
141 | 1; |
8595641b |
142 | |
0b6e5fff |
143 | =head1 NAME |
144 | |
145 | Sub::Quote - efficient generation of subroutines via string eval |
8595641b |
146 | |
147 | =head1 SYNOPSIS |
148 | |
149 | package Silly; |
150 | |
151 | use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub); |
152 | |
153 | quote_sub 'Silly::kitty', q{ print "meow" }; |
154 | |
155 | quote_sub 'Silly::doggy', q{ print "woof" }; |
156 | |
6b3002b2 |
157 | my $sound = 0; |
8595641b |
158 | |
159 | quote_sub 'Silly::dagron', |
6b3002b2 |
160 | q{ print ++$sound % 2 ? 'burninate' : 'roar' }, |
8595641b |
161 | { '$sound' => \$sound }; |
162 | |
163 | And elsewhere: |
164 | |
165 | Silly->kitty; # meow |
166 | Silly->doggy; # woof |
167 | Silly->dagron; # burninate |
168 | Silly->dagron; # roar |
169 | Silly->dagron; # burninate |
170 | |
171 | =head1 DESCRIPTION |
172 | |
173 | This package provides performant ways to generate subroutines from strings. |
174 | |
175 | =head1 SUBROUTINES |
176 | |
177 | =head2 quote_sub |
178 | |
d925a566 |
179 | my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 }; |
8595641b |
180 | |
181 | Arguments: ?$name, $code, ?\%captures, ?\%options |
182 | |
183 | C<$name> is the subroutine where the coderef will be installed. |
184 | |
185 | C<$code> is a string that will be turned into code. |
186 | |
187 | C<\%captures> is a hashref of variables that will be made available to the |
188 | code. See the L</SYNOPSIS>'s C<Silly::dagron> for an example using captures. |
189 | |
190 | =head3 options |
191 | |
192 | =over 2 |
193 | |
194 | =item * no_install |
195 | |
196 | B<Boolean>. Set this option to not install the generated coderef into the |
005c00f2 |
197 | passed subroutine name on undefer. |
8595641b |
198 | |
199 | =back |
200 | |
201 | =head2 unquote_sub |
202 | |
005c00f2 |
203 | my $coderef = unquote_sub $sub; |
8595641b |
204 | |
0d39f9d3 |
205 | Forcibly replace subroutine with actual code. Note that for performance |
206 | reasons all quoted subs declared so far will be globally unquoted/parsed in |
207 | a single eval. This means that if you have a syntax error in one of your |
208 | quoted subs you may find out when some other sub is unquoted. |
8595641b |
209 | |
005c00f2 |
210 | If $sub is not a quoted sub, this is a no-op. |
211 | |
8595641b |
212 | =head2 quoted_from_sub |
213 | |
005c00f2 |
214 | my $data = quoted_from_sub $sub; |
215 | |
216 | my ($name, $code, $captures, $compiled_sub) = @$data; |
217 | |
218 | Returns original arguments to quote_sub, plus the compiled version if this |
219 | sub has already been unquoted. |
8595641b |
220 | |
005c00f2 |
221 | Note that $sub can be either the original quoted version or the compiled |
222 | version for convenience. |
8595641b |
223 | |
224 | =head2 inlinify |
225 | |
226 | my $prelude = capture_unroll { |
227 | '$x' => 1, |
228 | '$y' => 2, |
229 | }; |
230 | |
231 | my $inlined_code = inlinify q{ |
232 | my ($x, $y) = @_; |
233 | |
234 | print $x + $y . "\n"; |
235 | }, '$x, $y', $prelude; |
236 | |
237 | Takes a string of code, a string of arguments, a string of code which acts as a |
238 | "prelude", and a B<Boolean> representing whether or not to localize the |
239 | arguments. |
240 | |
241 | =head2 capture_unroll |
242 | |
243 | my $prelude = capture_unroll { |
244 | '$x' => 1, |
245 | '$y' => 2, |
246 | }; |
247 | |
248 | Generates a snippet of code which is suitable to be used as a prelude for |
249 | L</inlinify>. The keys are the names of the variables and the values are (duh) |
250 | the values. Note that references work as values. |