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'; |
9 | use base qw(Exporter); |
10 | |
625d6219 |
11 | our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); |
a165a07f |
12 | |
13 | our %QUOTE_OUTSTANDING; |
14 | |
15 | our %QUOTED; |
16 | |
8c6626cf |
17 | sub capture_unroll { |
18 | my ($from, $captures, $indent) = @_; |
19 | join( |
20 | '', |
21 | map { |
22 | /^([\@\%\$])/ |
17a8e3f0 |
23 | or die "capture key should start with \@, \% or \$: $_"; |
8c6626cf |
24 | (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n}; |
25 | } keys %$captures |
26 | ); |
27 | } |
28 | |
a165a07f |
29 | sub _unquote_all_outstanding { |
30 | return unless %QUOTE_OUTSTANDING; |
31 | my ($assembled_code, @assembled_captures, @localize_these) = ''; |
6d377074 |
32 | # we sort the keys in order to make debugging more predictable |
33 | foreach my $outstanding (sort keys %QUOTE_OUTSTANDING) { |
a165a07f |
34 | my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}}; |
35 | |
36 | push @localize_these, $name if $name; |
37 | |
38 | my $make_sub = "{\n"; |
39 | |
40 | if (keys %$captures) { |
41 | my $ass_cap_count = @assembled_captures; |
8c6626cf |
42 | $make_sub .= capture_unroll("\$_[1][${ass_cap_count}]", $captures, 2); |
a165a07f |
43 | push @assembled_captures, $captures; |
44 | } |
45 | |
46 | my $o_quoted = perlstring $outstanding; |
47 | $make_sub .= ( |
48 | $name |
934ea2c1 |
49 | # disable the 'variable $x will not stay shared' warning since |
50 | # we're not letting it escape from this scope anyway so there's |
51 | # nothing trying to share it |
a165a07f |
52 | ? " no warnings 'closure';\n sub ${name} {\n" |
934ea2c1 |
53 | : " \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n" |
a165a07f |
54 | ); |
55 | $make_sub .= $code; |
56 | $make_sub .= " }".($name ? '' : ';')."\n"; |
57 | if ($name) { |
58 | $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; |
59 | } |
60 | $make_sub .= "}\n"; |
61 | $assembled_code .= $make_sub; |
62 | } |
a16d301e |
63 | my $debug_code = $assembled_code; |
a165a07f |
64 | if (@localize_these) { |
a16d301e |
65 | $debug_code = |
e8b2bab6 |
66 | "# localizing: ".join(', ', @localize_these)."\n" |
67 | .$assembled_code; |
a165a07f |
68 | $assembled_code = join("\n", |
69 | (map { "local *${_};" } @localize_these), |
a16d301e |
70 | 'eval '.perlstring($assembled_code).'; die $@ if $@;' |
a165a07f |
71 | ); |
e8b2bab6 |
72 | } else { |
73 | $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code; |
a165a07f |
74 | } |
a16d301e |
75 | $assembled_code .= "\n1;"; |
76 | unless (_clean_eval $assembled_code, \@assembled_captures) { |
77 | die "Eval went very, very wrong:\n\n${debug_code}\n\n$@"; |
a165a07f |
78 | } |
a16d301e |
79 | $ENV{SUB_QUOTE_DEBUG} && warn $debug_code; |
a165a07f |
80 | %QUOTE_OUTSTANDING = (); |
81 | } |
82 | |
83 | sub quote_sub { |
84 | # HOLY DWIMMERY, BATMAN! |
6f68f022 |
85 | # $name => $code => \%captures => \%options |
a165a07f |
86 | # $name => $code => \%captures |
87 | # $name => $code |
6f68f022 |
88 | # $code => \%captures => \%options |
a165a07f |
89 | # $code |
6f68f022 |
90 | my $options = |
91 | (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH') |
92 | ? pop |
93 | : {}; |
a165a07f |
94 | my $captures = pop if ref($_[-1]) eq 'HASH'; |
625d6219 |
95 | undef($captures) if $captures && !keys %$captures; |
a165a07f |
96 | my $code = pop; |
97 | my $name = $_[0]; |
98 | my $outstanding; |
6f68f022 |
99 | my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub { |
a165a07f |
100 | unquote_sub($outstanding); |
101 | }; |
102 | $outstanding = "$deferred"; |
103 | $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [ |
104 | $name, $code, $captures |
105 | ]; |
106 | return $deferred; |
107 | } |
108 | |
109 | sub quoted_from_sub { |
110 | my ($sub) = @_; |
6d377074 |
111 | $QUOTED{$sub||''}; |
a165a07f |
112 | } |
113 | |
114 | sub unquote_sub { |
115 | my ($sub) = @_; |
116 | _unquote_all_outstanding; |
117 | $QUOTED{$sub}[3]; |
118 | } |
119 | |
120 | 1; |