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 Scalar::Util qw(weaken);
  10 use base qw(Exporter);
  11
  12 our $VERSION = '1.003000';
  13 $VERSION = eval $VERSION;
  14
  15 our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub);
  16
  17 our %QUOTED;
  18
  19 our %WEAK_REFS;
  20
  21 sub capture_unroll {
  22   my ($from, $captures, $indent) = @_;
  23   join(
  24     '',
  25     map {
  26       /^([\@\%\$])/
  27         or die "capture key should start with \@, \% or \$: $_";
  28       (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n};
  29     } keys %$captures
  30   );
  31 }
  32
  33 sub inlinify {
  34   my ($code, $args, $extra, $local) = @_;
  35   my $do = 'do { '.($extra||'');
  36   if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) {
  37     if ($code_args eq $args) {
  38       $do.$body.' }'
  39     } else {
  40       $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }';
  41     }
  42   } else {
  43     my $assign = '';
  44     if ($local || $args ne '@_') {
  45       $assign = ($local ? 'local ' : '').'@_ = ('.$args.'); ';
  46     }
  47     $do.$assign.$code.' }';
  48   }
  49 }
  50
  51 sub quote_sub {
  52   # HOLY DWIMMERY, BATMAN!
  53   # $name => $code => \%captures => \%options
  54   # $name => $code => \%captures
  55   # $name => $code
  56   # $code => \%captures => \%options
  57   # $code
  58   my $options =
  59     (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
  60       ? pop
  61       : {};
  62   my $captures = pop if ref($_[-1]) eq 'HASH';
  63   undef($captures) if $captures && !keys %$captures;
  64   my $code = pop;
  65   my $name = $_[0];
  66   my $outstanding;
  67   my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
  68     unquote_sub($outstanding);
  69   };
  70   $outstanding = "$deferred";
  71   $QUOTED{$outstanding} = [ $name, $code, $captures ];
  72   weaken($WEAK_REFS{$outstanding} = $deferred);
  73   return $deferred;
  74 }
  75
  76 sub quoted_from_sub {
  77   my ($sub) = @_;
  78   $WEAK_REFS{$sub||''} and $QUOTED{$sub||''};
  79 }
  80
  81 sub unquote_sub {
  82   my ($sub) = @_;
  83   unless ($QUOTED{$sub}[3]) {
  84     my ($name, $code, $captures) = @{$QUOTED{$sub}};
  85
  86     my $make_sub = "{\n";
  87
  88     if (keys %$captures) {
  89       $make_sub .= capture_unroll("\$_[1]", $captures, 2);
  90     }
  91
  92     my $o_quoted = perlstring $sub;
  93     $make_sub .= (
  94       $name
  95           # disable the 'variable $x will not stay shared' warning since
  96           # we're not letting it escape from this scope anyway so there's
  97           # nothing trying to share it
  98         ? "  no warnings 'closure';\n  sub ${name} {\n"
  99         : "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n"
 100     );
 101     $make_sub .= $code;
 102     $make_sub .= "  }".($name ? '' : ';')."\n";
 103     if ($name) {
 104       $make_sub .= "  \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n";
 105     }
 106     $make_sub .= "}\n1;\n";
 107     $ENV{SUB_QUOTE_DEBUG} && warn $make_sub;
 108     {
 109       local $@;
 110       no strict 'refs';
 111       local *{$name} if $name;
 112       unless (_clean_eval $make_sub, $captures) {
 113         die "Eval went very, very wrong:\n\n${make_sub}\n\n$@";
 114       }
 115     }
 116   }
 117   $QUOTED{$sub}[3];
 118 }
 119
 120 1;
 121
 122 =head1 NAME
 123
 124 Sub::Quote - efficient generation of subroutines via string eval
 125
 126 =head1 SYNOPSIS
 127
 128  package Silly;
 129
 130  use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
 131
 132  quote_sub 'Silly::kitty', q{ print "meow" };
 133
 134  quote_sub 'Silly::doggy', q{ print "woof" };
 135
 136  my $sound = 0;
 137
 138  quote_sub 'Silly::dagron',
 139    q{ print ++$sound % 2 ? 'burninate' : 'roar' },
 140    { '$sound' => \$sound };
 141
 142 And elsewhere:
 143
 144  Silly->kitty;  # meow
 145  Silly->doggy;  # woof
 146  Silly->dagron; # burninate
 147  Silly->dagron; # roar
 148  Silly->dagron; # burninate
 149
 150 =head1 DESCRIPTION
 151
 152 This package provides performant ways to generate subroutines from strings.
 153
 154 =head1 SUBROUTINES
 155
 156 =head2 quote_sub
 157
 158  my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
 159
 160 Arguments: ?$name, $code, ?\%captures, ?\%options
 161
 162 C<$name> is the subroutine where the coderef will be installed.
 163
 164 C<$code> is a string that will be turned into code.
 165
 166 C<\%captures> is a hashref of variables that will be made available to the
 167 code.  See the L</SYNOPSIS>'s C<Silly::dagron> for an example using captures.
 168
 169 =head3 options
 170
 171 =over 2
 172
 173 =item * no_install
 174
 175 B<Boolean>.  Set this option to not install the generated coderef into the
 176 passed subroutine name on undefer.
 177
 178 =back
 179
 180 =head2 unquote_sub
 181
 182  my $coderef = unquote_sub $sub;
 183
 184 Forcibly replace subroutine with actual code.
 185
 186 If $sub is not a quoted sub, this is a no-op.
 187
 188 =head2 quoted_from_sub
 189
 190  my $data = quoted_from_sub $sub;
 191
 192  my ($name, $code, $captures, $compiled_sub) = @$data;
 193
 194 Returns original arguments to quote_sub, plus the compiled version if this
 195 sub has already been unquoted.
 196
 197 Note that $sub can be either the original quoted version or the compiled
 198 version for convenience.
 199
 200 =head2 inlinify
 201
 202  my $prelude = capture_unroll '$captures', {
 203    '$x' => 1,
 204    '$y' => 2,
 205  };
 206
 207  my $inlined_code = inlinify q{
 208    my ($x, $y) = @_;
 209
 210    print $x + $y . "\n";
 211  }, '$x, $y', $prelude;
 212
 213 Takes a string of code, a string of arguments, a string of code which acts as a
 214 "prelude", and a B<Boolean> representing whether or not to localize the
 215 arguments.
 216
 217 =head2 capture_unroll
 218
 219  my $prelude = capture_unroll '$captures', {
 220    '$x' => 1,
 221    '$y' => 2,
 222  }, 4;
 223
 224 Arguments: $from, \%captures, $indent
 225
 226 Generates a snippet of code which is suitable to be used as a prelude for
 227 L</inlinify>.  C<$from> is a string will be used as a hashref in the resulting
 228 code.  The keys of C<%captures> are the names of the variables and the values
 229 are ignored.  C<$indent> is the number of spaces to indent the result by.
 230
 231 =head1 CAVEATS
 232
 233 Much of this is just string-based code-generation, and as a result, a few caveats
 234 apply.
 235
 236 =head2 return
 237
 238 Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
 239 Instead of returning from the code you defined in C<quote_sub>, it will return
 240 from the overall function it is composited into.
 241
 242 So when you pass in:
 243
 244    quote_sub q{  return 1 if $condition; $morecode }
 245
 246 It might turn up in the intended context as follows:
 247
 248   sub foo {
 249
 250     <important code a>
 251     do {
 252       return 1 if $condition;
 253       $morecode
 254     };
 255     <important code b>
 256
 257   }
 258
 259 Which will obviously return from foo, when all you meant to do was return from
 260 the code context in quote_sub and proceed with running important code b.
 261
 262 =head2 strictures
 263
 264 Sub::Quote compiles quoted subs in an environment where C<< use strictures >>
 265 is in effect. L<strictures> enables L<strict> and FATAL L<warnings>.
 266
 267 The following dies I<< Use of uninitialized value in print... >>
 268
 269  no warnings;
 270  quote_sub 'Silly::kitty', q{ print undef };
 271
 272 If you need to disable parts of strictures, do it within the quoted sub:
 273
 274  quote_sub 'Silly::kitty', q{ no warnings; print undef };
 275
 276 =head1 SUPPORT
 277
 278 See L<Moo> for support and contact information.
 279
 280 =head1 AUTHORS
 281
 282 See L<Moo> for authors.
 283
 284 =head1 COPYRIGHT AND LICENSE
 285
 286 See L<Moo> for the copyright and license.