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