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.003001';
  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.  The keys should be the full name of the variable to be made available,
 171 including the sigil.  The values should be references to the values.  The
 172 variables will contain copies of the values.  See the L</SYNOPSIS>'s
 173 C<Silly::dagron> for an example using captures.
 174
 175 =head3 options
 176
 177 =over 2
 178
 179 =item * no_install
 180
 181 B<Boolean>.  Set this option to not install the generated coderef into the
 182 passed subroutine name on undefer.
 183
 184 =back
 185
 186 =head2 unquote_sub
 187
 188  my $coderef = unquote_sub $sub;
 189
 190 Forcibly replace subroutine with actual code.
 191
 192 If $sub is not a quoted sub, this is a no-op.
 193
 194 =head2 quoted_from_sub
 195
 196  my $data = quoted_from_sub $sub;
 197
 198  my ($name, $code, $captures, $compiled_sub) = @$data;
 199
 200 Returns original arguments to quote_sub, plus the compiled version if this
 201 sub has already been unquoted.
 202
 203 Note that $sub can be either the original quoted version or the compiled
 204 version for convenience.
 205
 206 =head2 inlinify
 207
 208  my $prelude = capture_unroll '$captures', {
 209    '$x' => 1,
 210    '$y' => 2,
 211  };
 212
 213  my $inlined_code = inlinify q{
 214    my ($x, $y) = @_;
 215
 216    print $x + $y . "\n";
 217  }, '$x, $y', $prelude;
 218
 219 Takes a string of code, a string of arguments, a string of code which acts as a
 220 "prelude", and a B<Boolean> representing whether or not to localize the
 221 arguments.
 222
 223 =head2 capture_unroll
 224
 225  my $prelude = capture_unroll '$captures', {
 226    '$x' => 1,
 227    '$y' => 2,
 228  }, 4;
 229
 230 Arguments: $from, \%captures, $indent
 231
 232 Generates a snippet of code which is suitable to be used as a prelude for
 233 L</inlinify>.  C<$from> is a string will be used as a hashref in the resulting
 234 code.  The keys of C<%captures> are the names of the variables and the values
 235 are ignored.  C<$indent> is the number of spaces to indent the result by.
 236
 237 =head1 CAVEATS
 238
 239 Much of this is just string-based code-generation, and as a result, a few caveats
 240 apply.
 241
 242 =head2 return
 243
 244 Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
 245 Instead of returning from the code you defined in C<quote_sub>, it will return
 246 from the overall function it is composited into.
 247
 248 So when you pass in:
 249
 250    quote_sub q{  return 1 if $condition; $morecode }
 251
 252 It might turn up in the intended context as follows:
 253
 254   sub foo {
 255
 256     <important code a>
 257     do {
 258       return 1 if $condition;
 259       $morecode
 260     };
 261     <important code b>
 262
 263   }
 264
 265 Which will obviously return from foo, when all you meant to do was return from
 266 the code context in quote_sub and proceed with running important code b.
 267
 268 =head2 strictures
 269
 270 Sub::Quote compiles quoted subs in an environment where C<< use strictures >>
 271 is in effect. L<strictures> enables L<strict> and FATAL L<warnings>.
 272
 273 The following dies I<< Use of uninitialized value in print... >>
 274
 275  no warnings;
 276  quote_sub 'Silly::kitty', q{ print undef };
 277
 278 If you need to disable parts of strictures, do it within the quoted sub:
 279
 280  quote_sub 'Silly::kitty', q{ no warnings; print undef };
 281
 282 =head1 SUPPORT
 283
 284 See L<Moo> for support and contact information.
 285
 286 =head1 AUTHORS
 287
 288 See L<Moo> for authors.
 289
 290 =head1 COPYRIGHT AND LICENSE
 291
 292 See L<Moo> for the copyright and license.