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 __END__
 125
 126 =head1 NAME
 127
 128 Sub::Quote - efficient generation of subroutines via string eval
 129
 130 =head1 SYNOPSIS
 131
 132  package Silly;
 133
 134  use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
 135
 136  quote_sub 'Silly::kitty', q{ print "meow" };
 137
 138  quote_sub 'Silly::doggy', q{ print "woof" };
 139
 140  my $sound = 0;
 141
 142  quote_sub 'Silly::dagron',
 143    q{ print ++$sound % 2 ? 'burninate' : 'roar' },
 144    { '$sound' => \$sound };
 145
 146 And elsewhere:
 147
 148  Silly->kitty;  # meow
 149  Silly->doggy;  # woof
 150  Silly->dagron; # burninate
 151  Silly->dagron; # roar
 152  Silly->dagron; # burninate
 153
 154 =head1 DESCRIPTION
 155
 156 This package provides performant ways to generate subroutines from strings.
 157
 158 =head1 SUBROUTINES
 159
 160 =head2 quote_sub
 161
 162  my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
 163
 164 Arguments: ?$name, $code, ?\%captures, ?\%options
 165
 166 C<$name> is the subroutine where the coderef will be installed.
 167
 168 C<$code> is a string that will be turned into code.
 169
 170 C<\%captures> is a hashref of variables that will be made available to the
 171 code.  The keys should be the full name of the variable to be made available,
 172 including the sigil.  The values should be references to the values.  The
 173 variables will contain copies of the values.  See the L</SYNOPSIS>'s
 174 C<Silly::dagron> for an example using captures.
 175
 176 =head3 options
 177
 178 =over 2
 179
 180 =item * no_install
 181
 182 B<Boolean>.  Set this option to not install the generated coderef into the
 183 passed subroutine name on undefer.
 184
 185 =back
 186
 187 =head2 unquote_sub
 188
 189  my $coderef = unquote_sub $sub;
 190
 191 Forcibly replace subroutine with actual code.
 192
 193 If $sub is not a quoted sub, this is a no-op.
 194
 195 =head2 quoted_from_sub
 196
 197  my $data = quoted_from_sub $sub;
 198
 199  my ($name, $code, $captures, $compiled_sub) = @$data;
 200
 201 Returns original arguments to quote_sub, plus the compiled version if this
 202 sub has already been unquoted.
 203
 204 Note that $sub can be either the original quoted version or the compiled
 205 version for convenience.
 206
 207 =head2 inlinify
 208
 209  my $prelude = capture_unroll '$captures', {
 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 '$captures', {
 227    '$x' => 1,
 228    '$y' => 2,
 229  }, 4;
 230
 231 Arguments: $from, \%captures, $indent
 232
 233 Generates a snippet of code which is suitable to be used as a prelude for
 234 L</inlinify>.  C<$from> is a string will be used as a hashref in the resulting
 235 code.  The keys of C<%captures> are the names of the variables and the values
 236 are ignored.  C<$indent> is the number of spaces to indent the result by.
 237
 238 =head1 CAVEATS
 239
 240 Much of this is just string-based code-generation, and as a result, a few caveats
 241 apply.
 242
 243 =head2 return
 244
 245 Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
 246 Instead of returning from the code you defined in C<quote_sub>, it will return
 247 from the overall function it is composited into.
 248
 249 So when you pass in:
 250
 251    quote_sub q{  return 1 if $condition; $morecode }
 252
 253 It might turn up in the intended context as follows:
 254
 255   sub foo {
 256
 257     <important code a>
 258     do {
 259       return 1 if $condition;
 260       $morecode
 261     };
 262     <important code b>
 263
 264   }
 265
 266 Which will obviously return from foo, when all you meant to do was return from
 267 the code context in quote_sub and proceed with running important code b.
 268
 269 =head2 strictures
 270
 271 Sub::Quote compiles quoted subs in an environment where C<< use strictures >>
 272 is in effect. L<strictures> enables L<strict> and FATAL L<warnings>.
 273
 274 The following dies I<< Use of uninitialized value in print... >>
 275
 276  no warnings;
 277  quote_sub 'Silly::kitty', q{ print undef };
 278
 279 If you need to disable parts of strictures, do it within the quoted sub:
 280
 281  quote_sub 'Silly::kitty', q{ no warnings; print undef };
 282
 283 =head1 SUPPORT
 284
 285 See L<Moo> for support and contact information.
 286
 287 =head1 AUTHORS
 288
 289 See L<Moo> for authors.
 290
 291 =head1 COPYRIGHT AND LICENSE
 292
 293 See L<Moo> for the copyright and license.
 294
 295 =cut