fix indentation in generated constructor
[gitmo/Role-Tiny.git] / lib / Sub / Quote.pm
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
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
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     $ENV{SUB_QUOTE_DEBUG} && warn
59       "# localizing: ".join(', ', @localize_these)."\n"
60       .$assembled_code;
61     $assembled_code = join("\n",
62       (map { "local *${_};" } @localize_these),
63       'eval '.perlstring $assembled_code
64     );
65   } else {
66     $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code;
67   }
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
75 sub quote_sub {
76   # HOLY DWIMMERY, BATMAN!
77   # $name => $code => \%captures => \%options
78   # $name => $code => \%captures
79   # $name => $code
80   # $code => \%captures => \%options
81   # $code
82   my $options =
83     (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
84       ? pop
85       : {};
86   my $captures = pop if ref($_[-1]) eq 'HASH';
87   my $code = pop;
88   my $name = $_[0];
89   my $outstanding;
90   my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
91     unquote_sub($outstanding);
92   };
93   $outstanding = "$deferred";
94   $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [
95     $name, $code, $captures
96   ];
97   return $deferred;
98 }
99
100 sub quoted_from_sub {
101   my ($sub) = @_;
102   $QUOTED{$sub};
103 }
104
105 sub unquote_sub {
106   my ($sub) = @_;
107   _unquote_all_outstanding;
108   $QUOTED{$sub}[3];
109 }
110
111 1;