5 sub _clean_eval { eval $_[0] }
9 use Scalar::Util qw(weaken);
10 use base qw(Exporter);
12 our $VERSION = '1.003000';
13 $VERSION = eval $VERSION;
15 our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub);
22 my ($from, $captures, $indent) = @_;
27 or die "capture key should start with \@, \% or \$: $_";
28 (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n};
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) {
40 $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }';
44 if ($local || $args ne '@_') {
45 $assign = ($local ? 'local ' : '').'@_ = ('.$args.'); ';
47 $do.$assign.$code.' }';
52 # HOLY DWIMMERY, BATMAN!
53 # $name => $code => \%captures => \%options
54 # $name => $code => \%captures
56 # $code => \%captures => \%options
59 (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
62 my $captures = pop if ref($_[-1]) eq 'HASH';
63 undef($captures) if $captures && !keys %$captures;
67 my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
68 unquote_sub($quoted_info->[4]);
70 $quoted_info = [ $name, $code, $captures, undef, $deferred ];
71 weaken($QUOTED{$deferred} = $quoted_info);
82 unless ($QUOTED{$sub}[3]) {
83 my ($name, $code, $captures) = @{$QUOTED{$sub}};
87 my %captures = $captures ? %$captures : ();
88 $captures{'$_QUOTED'} = \$QUOTED{$sub};
89 $make_sub .= capture_unroll("\$_[1]", \%captures, 2);
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"
100 $make_sub .= " }".($name ? '' : ';')."\n";
102 $make_sub .= " \$_QUOTED->[3] = \\&${name}\n";
104 $make_sub .= "}\n1;\n";
105 $ENV{SUB_QUOTE_DEBUG} && warn $make_sub;
109 local *{$name} if $name;
110 unless (_clean_eval $make_sub, \%captures) {
111 die "Eval went very, very wrong:\n\n${make_sub}\n\n$@";
119 %QUOTED = map { defined $_ ? ($_->[4] => $_) : () } values %QUOTED;
120 weaken($_) for values %QUOTED;
127 Sub::Quote - efficient generation of subroutines via string eval
133 use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
135 quote_sub 'Silly::kitty', q{ print "meow" };
137 quote_sub 'Silly::doggy', q{ print "woof" };
141 quote_sub 'Silly::dagron',
142 q{ print ++$sound % 2 ? 'burninate' : 'roar' },
143 { '$sound' => \$sound };
149 Silly->dagron; # burninate
150 Silly->dagron; # roar
151 Silly->dagron; # burninate
155 This package provides performant ways to generate subroutines from strings.
161 my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
163 Arguments: ?$name, $code, ?\%captures, ?\%options
165 C<$name> is the subroutine where the coderef will be installed.
167 C<$code> is a string that will be turned into code.
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.
181 B<Boolean>. Set this option to not install the generated coderef into the
182 passed subroutine name on undefer.
188 my $coderef = unquote_sub $sub;
190 Forcibly replace subroutine with actual code.
192 If $sub is not a quoted sub, this is a no-op.
194 =head2 quoted_from_sub
196 my $data = quoted_from_sub $sub;
198 my ($name, $code, $captures, $compiled_sub) = @$data;
200 Returns original arguments to quote_sub, plus the compiled version if this
201 sub has already been unquoted.
203 Note that $sub can be either the original quoted version or the compiled
204 version for convenience.
208 my $prelude = capture_unroll '$captures', {
213 my $inlined_code = inlinify q{
216 print $x + $y . "\n";
217 }, '$x, $y', $prelude;
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
223 =head2 capture_unroll
225 my $prelude = capture_unroll '$captures', {
230 Arguments: $from, \%captures, $indent
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.
239 Much of this is just string-based code-generation, and as a result, a few caveats
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.
250 quote_sub q{ return 1 if $condition; $morecode }
252 It might turn up in the intended context as follows:
258 return 1 if $condition;
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.
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>.
273 The following dies I<< Use of uninitialized value in print... >>
276 quote_sub 'Silly::kitty', q{ print undef };
278 If you need to disable parts of strictures, do it within the quoted sub:
280 quote_sub 'Silly::kitty', q{ no warnings; print undef };
284 See L<Moo> for support and contact information.
288 See L<Moo> for authors.
290 =head1 COPYRIGHT AND LICENSE
292 See L<Moo> for the copyright and license.