fix indentation in generated constructor
[gitmo/Role-Tiny.git] / lib / Sub / Quote.pm
CommitLineData
a165a07f 1package Sub::Quote;
2
3use strictures 1;
4
5sub _clean_eval { eval $_[0] }
6
7use Sub::Defer;
8use B 'perlstring';
9use base qw(Exporter);
10
11our @EXPORT = qw(quote_sub unquote_sub);
12
13our %QUOTE_OUTSTANDING;
14
15our %QUOTED;
16
17sub _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) {
e8b2bab6 58 $ENV{SUB_QUOTE_DEBUG} && warn
59 "# localizing: ".join(', ', @localize_these)."\n"
60 .$assembled_code;
a165a07f 61 $assembled_code = join("\n",
62 (map { "local *${_};" } @localize_these),
63 'eval '.perlstring $assembled_code
64 );
e8b2bab6 65 } else {
66 $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code;
a165a07f 67 }
a165a07f 68 _clean_eval $assembled_code, \@assembled_captures;
69 if ($@) {
70 die "Eval went very, very wrong:\n\n${assembled_code}\n\n$@";
71 }
72 %QUOTE_OUTSTANDING = ();
73}
74
75sub quote_sub {
76 # HOLY DWIMMERY, BATMAN!
6f68f022 77 # $name => $code => \%captures => \%options
a165a07f 78 # $name => $code => \%captures
79 # $name => $code
6f68f022 80 # $code => \%captures => \%options
a165a07f 81 # $code
6f68f022 82 my $options =
83 (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
84 ? pop
85 : {};
a165a07f 86 my $captures = pop if ref($_[-1]) eq 'HASH';
87 my $code = pop;
88 my $name = $_[0];
89 my $outstanding;
6f68f022 90 my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
a165a07f 91 unquote_sub($outstanding);
92 };
93 $outstanding = "$deferred";
94 $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [
95 $name, $code, $captures
96 ];
97 return $deferred;
98}
99
100sub quoted_from_sub {
101 my ($sub) = @_;
102 $QUOTED{$sub};
103}
104
105sub unquote_sub {
106 my ($sub) = @_;
107 _unquote_all_outstanding;
108 $QUOTED{$sub}[3];
109}
110
1111;