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 | |
11 | our @EXPORT = qw(quote_sub unquote_sub); |
12 | |
13 | our %QUOTE_OUTSTANDING; |
14 | |
15 | our %QUOTED; |
16 | |
17 | sub _unquote_all_outstanding { |
18 | return unless %QUOTE_OUTSTANDING; |
19 | my ($assembled_code, @assembled_captures, @localize_these) = ''; |
20 | foreach my $outstanding (keys %QUOTE_OUTSTANDING) { |
21 | my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}}; |
22 | |
23 | push @localize_these, $name if $name; |
24 | |
25 | my $make_sub = "{\n"; |
26 | |
27 | if (keys %$captures) { |
28 | my $ass_cap_count = @assembled_captures; |
29 | $make_sub .= join( |
30 | "\n", |
31 | map { |
32 | /^([\@\%\$])/ |
33 | or die "capture key should start with \@, \% or \$: $_"; |
34 | qq{ my ${_} = ${1}{\$_[1][${ass_cap_count}]{${\perlstring $_}}};\n}; |
35 | } keys %$captures |
36 | ); |
37 | push @assembled_captures, $captures; |
38 | } |
39 | |
40 | my $o_quoted = perlstring $outstanding; |
41 | $make_sub .= ( |
42 | $name |
ea4b7a8a |
43 | # disable the 'variable $x will not stay shared' warning since |
44 | # we're not letting it escape from this scope anyway so there's |
45 | # nothing trying to share it |
a165a07f |
46 | ? " no warnings 'closure';\n sub ${name} {\n" |
47 | : " \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n" |
48 | ); |
49 | $make_sub .= $code; |
50 | $make_sub .= " }".($name ? '' : ';')."\n"; |
51 | if ($name) { |
52 | $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; |
53 | } |
54 | $make_sub .= "}\n"; |
55 | $assembled_code .= $make_sub; |
56 | } |
57 | if (@localize_these) { |
58 | $assembled_code = join("\n", |
59 | (map { "local *${_};" } @localize_these), |
60 | 'eval '.perlstring $assembled_code |
61 | ); |
62 | } |
63 | $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code; |
64 | _clean_eval $assembled_code, \@assembled_captures; |
65 | if ($@) { |
66 | die "Eval went very, very wrong:\n\n${assembled_code}\n\n$@"; |
67 | } |
68 | %QUOTE_OUTSTANDING = (); |
69 | } |
70 | |
71 | sub quote_sub { |
72 | # HOLY DWIMMERY, BATMAN! |
73 | # $name => $code => \%captures |
74 | # $name => $code |
75 | # $code => \%captures |
76 | # $code |
77 | my $captures = pop if ref($_[-1]) eq 'HASH'; |
78 | my $code = pop; |
79 | my $name = $_[0]; |
80 | my $outstanding; |
81 | my $deferred = defer_sub $name => sub { |
82 | unquote_sub($outstanding); |
83 | }; |
84 | $outstanding = "$deferred"; |
85 | $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [ |
86 | $name, $code, $captures |
87 | ]; |
88 | return $deferred; |
89 | } |
90 | |
91 | sub quoted_from_sub { |
92 | my ($sub) = @_; |
93 | $QUOTED{$sub}; |
94 | } |
95 | |
96 | sub unquote_sub { |
97 | my ($sub) = @_; |
98 | _unquote_all_outstanding; |
99 | $QUOTED{$sub}[3]; |
100 | } |
101 | |
102 | 1; |