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