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 quoted_from_sub);
  12
  13 our %QUOTE_OUTSTANDING;
  14
  15 our %QUOTED;
  16
  17 sub capture_unroll {
  18   my ($from, $captures, $indent) = @_;
  19   join(
  20     '',
  21     map {
  22       /^([\@\%\$])/
  23         or die "capture key should start with \@, \% or \$: $_";
  24       (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n};
  25     } keys %$captures
  26   );
  27 }
  28
  29 sub inlinify {
  30   my ($code, $args, $extra, $local) = @_;
  31   my $do = 'do { '.($extra||'');
  32   if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) {
  33     if ($code_args eq $args) {
  34       $do.$body.' }'
  35     } else {
  36       $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }';
  37     }
  38   } else {
  39     $do.($local ? 'local ' : '').'@_ = ('.$args.'); '.$code.' }';
  40   }
  41 }
  42
  43 sub _unquote_all_outstanding {
  44   return unless %QUOTE_OUTSTANDING;
  45   my ($assembled_code, @assembled_captures, @localize_these) = '';
  46   # we sort the keys in order to make debugging more predictable
  47   foreach my $outstanding (sort keys %QUOTE_OUTSTANDING) {
  48     my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}};
  49
  50     push @localize_these, $name if $name;
  51
  52     my $make_sub = "{\n";
  53
  54     if (keys %$captures) {
  55       my $ass_cap_count = @assembled_captures;
  56       $make_sub .= capture_unroll("\$_[1][${ass_cap_count}]", $captures, 2);
  57       push @assembled_captures, $captures;
  58     }
  59
  60     my $o_quoted = perlstring $outstanding;
  61     $make_sub .= (
  62       $name
  63           # disable the 'variable $x will not stay shared' warning since
  64           # we're not letting it escape from this scope anyway so there's
  65           # nothing trying to share it
  66         ? "  no warnings 'closure';\n  sub ${name} {\n"
  67         : "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n"
  68     );
  69     $make_sub .= $code;
  70     $make_sub .= "  }".($name ? '' : ';')."\n";
  71     if ($name) {
  72       $make_sub .= "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n";
  73     }
  74     $make_sub .= "}\n";
  75     $assembled_code .= $make_sub;
  76   }
  77   my $debug_code = $assembled_code;
  78   if (@localize_these) {
  79     $debug_code =
  80       "# localizing: ".join(', ', @localize_these)."\n"
  81       .$assembled_code;
  82     $assembled_code = join("\n",
  83       (map { "local *${_};" } @localize_these),
  84       'eval '.perlstring($assembled_code).'; die $@ if $@;'
  85     );
  86   } else {
  87     $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code;
  88   }
  89   $assembled_code .= "\n1;";
  90   unless (_clean_eval $assembled_code, \@assembled_captures) {
  91     die "Eval went very, very wrong:\n\n${debug_code}\n\n$@";
  92   }
  93   $ENV{SUB_QUOTE_DEBUG} && warn $debug_code;
  94   %QUOTE_OUTSTANDING = ();
  95 }
  96
  97 sub quote_sub {
  98   # HOLY DWIMMERY, BATMAN!
  99   # $name => $code => \%captures => \%options
 100   # $name => $code => \%captures
 101   # $name => $code
 102   # $code => \%captures => \%options
 103   # $code
 104   my $options =
 105     (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
 106       ? pop
 107       : {};
 108   my $captures = pop if ref($_[-1]) eq 'HASH';
 109   undef($captures) if $captures && !keys %$captures;
 110   my $code = pop;
 111   my $name = $_[0];
 112   my $outstanding;
 113   my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
 114     unquote_sub($outstanding);
 115   };
 116   $outstanding = "$deferred";
 117   $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [
 118     $name, $code, $captures
 119   ];
 120   return $deferred;
 121 }
 122
 123 sub quoted_from_sub {
 124   my ($sub) = @_;
 125   $QUOTED{$sub||''};
 126 }
 127
 128 sub unquote_sub {
 129   my ($sub) = @_;
 130   _unquote_all_outstanding;
 131   $QUOTED{$sub}[3];
 132 }
 133
 134 1;
 135
 136 =pod
 137
 138 =head1 SYNOPSIS
 139
 140  package Silly;
 141
 142  use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
 143
 144  quote_sub 'Silly::kitty', q{ print "meow" };
 145
 146  quote_sub 'Silly::doggy', q{ print "woof" };
 147
 148  my $sound; $$sound = 0;
 149
 150  quote_sub 'Silly::dagron',
 151    q{ print ++$$sound % 2 ? 'burninate' : 'roar' },
 152    { '$sound' => \$sound };
 153
 154 And elsewhere:
 155
 156  Silly->kitty;  # meow
 157  Silly->doggy;  # woof
 158  Silly->dagron; # burninate
 159  Silly->dagron; # roar
 160  Silly->dagron; # burninate
 161
 162 =head1 DESCRIPTION
 163
 164 This package provides performant ways to generate subroutines from strings.
 165
 166 =head1 SUBROUTINES
 167
 168 =head2 quote_sub
 169
 170  my $coderef = quote_sub 'Foo:bar', q{ print $x++ . "\n" }, { '$x' => \0 };
 171
 172 Arguments: ?$name, $code, ?\%captures, ?\%options
 173
 174 C<$name> is the subroutine where the coderef will be installed.
 175
 176 C<$code> is a string that will be turned into code.
 177
 178 C<\%captures> is a hashref of variables that will be made available to the
 179 code.  See the L</SYNOPSIS>'s C<Silly::dagron> for an example using captures.
 180
 181 =head3 options
 182
 183 =over 2
 184
 185 =item * no_install
 186
 187 B<Boolean>.  Set this option to not install the generated coderef into the
 188 passed subroutine.
 189
 190 =back
 191
 192 =head2 unquote_sub
 193
 194  my $coderef = unquote_sub 'Foo::bar';
 195
 196 Forcibly replace subroutine with actual code.  Note that as many subs are
 197 unquoted at a time for performance reasons.  This means that if you have a
 198 syntax error in one of your quoted subs you may find out when some other sub
 199 is unquoted.
 200
 201 =head2 quoted_from_sub
 202
 203  my $coderef = quoted_from_sub 'Foo::bar';
 204
 205 Returns quoted coderef based on subroutine name.
 206
 207 =head2 inlinify
 208
 209  my $prelude = capture_unroll {
 210    '$x' => 1,
 211    '$y' => 2,
 212  };
 213
 214  my $inlined_code = inlinify q{
 215    my ($x, $y) = @_;
 216
 217    print $x + $y . "\n";
 218  }, '$x, $y', $prelude;
 219
 220 Takes a string of code, a string of arguments, a string of code which acts as a
 221 "prelude", and a B<Boolean> representing whether or not to localize the
 222 arguments.
 223
 224 =head2 capture_unroll
 225
 226  my $prelude = capture_unroll {
 227    '$x' => 1,
 228    '$y' => 2,
 229  };
 230
 231 Generates a snippet of code which is suitable to be used as a prelude for
 232 L</inlinify>.  The keys are the names of the variables and the values are (duh)
 233 the values.  Note that references work as values.