1package Sub::Quote;
2
3sub _clean_eval { eval $_[0] }
4
5use strict;
6use warnings;
7
8use Sub::Defer qw(defer_sub);
9use Scalar::Util qw(weaken);
10use Exporter qw(import);
11use Carp qw(croak);
12BEGIN { our @CARP_NOT = qw(Sub::Defer) }
13use B ();
14BEGIN {
15  *_HAVE_IS_UTF8 = defined &utf8::is_utf8 ? sub(){1} : sub(){0};
16  *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
17  *_BAD_BACKSLASH_ESCAPE = _HAVE_PERLSTRING() && "$]" == 5.010_000 ? sub(){1} : sub(){0};
18  *_HAVE_HEX_FLOAT = !$ENV{SUB_QUOTE_NO_HEX_FLOAT} && "$]" >= 5.022 ? sub(){1} : sub(){0};
19
20  # This may not be perfect, as we can't tell the format purely from the size
21  # but it should cover the common cases, and other formats are more likely to
22  # be less precise.
23  my $nvsize = 8 * length pack 'F', 0;
24  my $nvmantbits
25    = $nvsize == 16   ? 11
26    : $nvsize == 32   ? 24
27    : $nvsize == 64   ? 53
28    : $nvsize == 80   ? 64
29    : $nvsize == 128  ? 113
30    : $nvsize == 256  ? 237
31                      : 237 # unknown float format
32    ;
33  my $precision = int( log(2)/log(10)*$nvmantbits );
34
35  *_NVSIZE = sub(){$nvsize};
36  *_NVMANTBITS = sub(){$nvmantbits};
37  *_FLOAT_PRECISION = sub(){$precision};
38}
39
40our $VERSION = '2.006006';
41$VERSION =~ tr/_//d;
42
43our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
44our @EXPORT_OK = qw(quotify capture_unroll inlinify sanitize_identifier);
45
46our %QUOTED;
47
48my %escape;
49if (_BAD_BACKSLASH_ESCAPE) {
50  %escape = (
51    (map +(chr($_) => sprintf '\x%02x', $_), 0 .. 0x31, 0x7f),
52    "\t" => "\\t",
53    "\n" => "\\n",
54    "\r" => "\\r",
55    "\f" => "\\f",
56    "\b" => "\\b",
57    "\a" => "\\a",
58    "\e" => "\\e",
59    (map +($_ => "\\$_"), qw(" \ $ @)),
60  );
61}
62
63sub quotify {
64  my $value = $_[0];
65  no warnings 'numeric';
66  ! defined $value     ? 'undef()'
67  # numeric detection
68  : (!(_HAVE_IS_UTF8 && utf8::is_utf8($value))
69    && length( (my $dummy = '') & $value )
70    && 0 + $value eq $value
71  ) ? (
72    $value != $value ? (
73      $value eq (9**9**9*0)
74        ? '(9**9**9*0)'    # nan
75        : '(-(9**9**9*0))' # -nan
76    )
77    : $value == 9**9**9  ? '(9**9**9)'     # inf
78    : $value == -9**9**9 ? '(-9**9**9)'    # -inf
79    : $value == 0 ? (
80      sprintf('%g', $value) eq '-0' ? '-0.0' : '0',
81    )
82    : $value !~ /[e.]/i ? (
83      $value > 0 ? (sprintf '%u', $value)
84                 : (sprintf '%d', $value)
85    )
86    : do {
87      my $float = $value;
88      my $max_factor = int( log( abs($value) ) / log(2) ) - _NVMANTBITS;
89      my $ex_sign = $max_factor > 0 ? 1 : -1;
90      FACTOR: for my $ex (0 .. abs($max_factor)) {
91        my $num = $value / 2**($ex_sign * $ex);
92        for my $precision (_FLOAT_PRECISION .. _FLOAT_PRECISION+2) {
93          my $formatted = sprintf '%.'.$precision.'g', $num;
94          $float = $formatted
95            if $ex == 0;
96          if ($formatted == $num) {
97            if ($ex) {
98              $float
99                = $formatted
100                . ($ex_sign == 1 ? '*' : '/')
101                . (
102                  $ex > _NVMANTBITS
103                    ? "2**$ex"
104                    : sprintf('%u', 2**$ex)
105                );
106            }
107            last FACTOR;
108          }
109        }
110        if (_HAVE_HEX_FLOAT) {
111          $float = sprintf '%a', $value;
112          last FACTOR;
113        }
114      }
115      "$float";
116    }
117  )
118  : !length($value) && length( (my $dummy2 = '') & $value ) ? '(!1)' # false
119  : _BAD_BACKSLASH_ESCAPE && _HAVE_IS_UTF8 && utf8::is_utf8($value) ? do {
120    $value =~ s/(["\$\@\\[:cntrl:]]|[^\x00-\x7f])/
121      $escape{$1} || sprintf('\x{%x}', ord($1))
122    /ge;
123    qq["$value"];
124  }
125  : _HAVE_PERLSTRING ? B::perlstring($value)
126  : qq["\Q$value\E"];
127}
128
129sub sanitize_identifier {
130  my $name = shift;
131  $name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
132  $name;
133}
134
135sub capture_unroll {
136  my ($from, $captures, $indent) = @_;
137  join(
138    '',
139    map {
140      /^([\@\%\$])/
141        or croak "capture key should start with \@, \% or \$: $_";
142      (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
143    } keys %$captures
144  );
145}
146
147sub inlinify {
148  my ($code, $args, $extra, $local) = @_;
149  $args = '()'
150    if !defined $args;
151  my $do = 'do { '.($extra||'');
152  if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
153    $do .= $1;
154  }
155  if ($code =~ s{
156    \A((?:\#\ BEGIN\ quote_sub\ PRELUDE\n.*?\#\ END\ quote_sub\ PRELUDE\n)?\s*)
157    (^\s*) my \s* \(([^)]+)\) \s* = \s* \@_;
158  }{}xms) {
159    my ($pre, $indent, $code_args) = ($1, $2, $3);
160    $do .= $pre;
161    if ($code_args ne $args) {
162      $do .= $indent . 'my ('.$code_args.') = ('.$args.'); ';
163    }
164  }
165  elsif ($local || $args ne '@_') {
166    $do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
167  }
168  $do.$code.' }';
169}
170
171sub quote_sub {
172  # HOLY DWIMMERY, BATMAN!
173  # $name => $code => \%captures => \%options
174  # $name => $code => \%captures
175  # $name => $code
176  # $code => \%captures => \%options
177  # $code
178  my $options =
179    (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
180      ? pop
181      : {};
182  my $captures = ref($_[-1]) eq 'HASH' ? pop : undef;
183  undef($captures) if $captures && !keys %$captures;
184  my $code = pop;
185  my $name = $_[0];
186  if ($name) {
187    my $subname = $name;
188    my $package = $subname =~ s/(.*)::// ? $1 : caller;
189    $name = join '::', $package, $subname;
190    croak qq{package name "$package" too long!}
191      if length $package > 252;
192    croak qq{package name "$package" is not valid!}
193      unless $package =~ /^[^\d\W]\w*(?:::\w+)*$/;
194    croak qq{sub name "$subname" too long!}
195      if length $subname > 252;
196    croak qq{sub name "$subname" is not valid!}
197      unless $subname =~ /^[^\d\W]\w*$/;
198  }
199  my @caller = caller(0);
200  my ($attributes, $file, $line) = @{$options}{qw(attributes file line)};
201  if ($attributes) {
202    /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
203      for @$attributes;
204  }
205  my $quoted_info = {
206    name     => $name,
207    code     => $code,
208    captures => $captures,
209    package      => (exists $options->{package}      ? $options->{package}      : $caller[0]),
210    hints        => (exists $options->{hints}        ? $options->{hints}        : $caller[8]),
211    warning_bits => (exists $options->{warning_bits} ? $options->{warning_bits} : $caller[9]),
212    hintshash    => (exists $options->{hintshash}    ? $options->{hintshash}    : $caller[10]),
213    ($attributes ? (attributes => $attributes) : ()),
214    ($file       ? (file => $file) : ()),
215    ($line       ? (line => $line) : ()),
216  };
217  my $unquoted;
218  weaken($quoted_info->{unquoted} = \$unquoted);
219  if ($options->{no_defer}) {
220    my $fake = \my $var;
221    local $QUOTED{$fake} = $quoted_info;
222    my $sub = unquote_sub($fake);
223    Sub::Defer::_install_coderef($name, $sub) if $name && !$options->{no_install};
224    return $sub;
225  }
226  else {
227    my $deferred = defer_sub(
228      ($options->{no_install} ? undef : $name),
229      sub {
230        $unquoted if 0;
231        unquote_sub($quoted_info->{deferred});
232      },
233      {
234        ($attributes ? ( attributes => $attributes ) : ()),
235        ($name ? () : ( package => $quoted_info->{package} )),
236      },
237    );
238    weaken($quoted_info->{deferred} = $deferred);
239    weaken($QUOTED{$deferred} = $quoted_info);
240    return $deferred;
241  }
242}
243
244sub _context {
245  my $info = shift;
246  $info->{context} ||= do {
247    my ($package, $hints, $warning_bits, $hintshash, $file, $line)
248      = @{$info}{qw(package hints warning_bits hintshash file line)};
249
250    $line ||= 1
251      if $file;
252
253    my $line_mark = '';
254    if ($line) {
255      $line_mark = "#line ".($line-1);
256      if ($file) {
257        $line_mark .= qq{ "$file"};
258      }
259      $line_mark .= "\n";
260    }
261
262    $info->{context}
263      ="# BEGIN quote_sub PRELUDE\n"
264      ."package $package;\n"
265      ."BEGIN {\n"
266      ."  \$^H = ".quotify($hints).";\n"
267      ."  \${^WARNING_BITS} = ".quotify($warning_bits).";\n"
268      ."  \%^H = (\n"
269      . join('', map
270      "    ".quotify($_)." => ".quotify($hintshash->{$_}).",\n",
271        grep !(ref $hintshash->{$_} && $hintshash->{$_} =~ /\A(?:\w+(?:::\w+)*=)?[A-Z]+\(0x[[0-9a-fA-F]+\)\z/),
272        keys %$hintshash)
273      ."  );\n"
274      ."}\n"
275      .$line_mark
276      ."# END quote_sub PRELUDE\n";
277  };
278}
279
280sub quoted_from_sub {
281  my ($sub) = @_;
282  my $quoted_info = $QUOTED{$sub||''} or return undef;
283  my ($name, $code, $captures, $unquoted, $deferred)
284    = @{$quoted_info}{qw(name code captures unquoted deferred)};
285  $code = _context($quoted_info) . $code;
286  $unquoted &&= $$unquoted;
287  if (($deferred && $deferred eq $sub)
288      || ($unquoted && $unquoted eq $sub)) {
289    return [ $name, $code, $captures, $unquoted, $deferred ];
290  }
291  return undef;
292}
293
294sub unquote_sub {
295  my ($sub) = @_;
296  my $quoted_info = $QUOTED{$sub} or return undef;
297  my $unquoted = $quoted_info->{unquoted};
298  unless ($unquoted && $$unquoted) {
299    my ($name, $code, $captures, $package, $attributes)
300      = @{$quoted_info}{qw(name code captures package attributes)};
301
302    ($package, $name) = $name =~ /(.*)::(.*)/
303      if $name;
304
305    my %captures = $captures ? %$captures : ();
306    $captures{'$_UNQUOTED'} = \$unquoted;
307    $captures{'$_QUOTED'} = \$quoted_info;
308
309    my $make_sub
310      = "{\n"
311      . capture_unroll("\$_[1]", \%captures, 2)
312      . "  package ${package};\n"
313      . (
314        $name
315          # disable the 'variable $x will not stay shared' warning since
316          # we're not letting it escape from this scope anyway so there's
317          # nothing trying to share it
318          ? "  no warnings 'closure';\n  sub ${name} "
319          : "  \$\$_UNQUOTED = sub "
320      )
321      . ($attributes ? join('', map ":$_ ", @$attributes) : '') . "{\n"
322      . "  (\$_QUOTED,\$_UNQUOTED) if 0;\n"
323      . _context($quoted_info)
324      . $code
325      . "  }".($name ? "\n  \$\$_UNQUOTED = \\&${name}" : '') . ";\n"
326      . "}\n"
327      . "1;\n";
328    if (my $debug = $ENV{SUB_QUOTE_DEBUG}) {
329      if ($debug =~ m{^([^\W\d]\w*(?:::\w+)*(?:::)?)$}) {
330        my $filter = $1;
331        my $match
332          = $filter =~ /::$/ ? $package.'::'
333          : $filter =~ /::/  ? $package.'::'.($name||'__ANON__')
334          : ($name||'__ANON__');
335        warn $make_sub
336          if $match eq $filter;
337      }
338      elsif ($debug =~ m{\A/(.*)/\z}s) {
339        my $filter = $1;
340        warn $make_sub
341          if $code =~ $filter;
342      }
343      else {
344        warn $make_sub;
345      }
346    }
347    {
348      no strict 'refs';
349      local *{"${package}::${name}"} if $name;
350      my ($success, $e);
351      {
352        local $@;
353        $success = _clean_eval($make_sub, \%captures);
354        $e = $@;
355      }
356      unless ($success) {
357        my $space = length($make_sub =~ tr/\n//);
358        my $line = 0;
359        $make_sub =~ s/^/sprintf "%${space}d: ", ++$line/emg;
360        croak "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
361      }
362      weaken($QUOTED{$$unquoted} = $quoted_info);
363    }
364  }
365  $$unquoted;
366}
367
368sub qsub ($) {
369  goto &quote_sub;
370}
371
372sub CLONE {
373  my @quoted = map { defined $_ ? (
374    $_->{unquoted} && ${$_->{unquoted}} ? (${ $_->{unquoted} } => $_) : (),
375    $_->{deferred} ? ($_->{deferred} => $_) : (),
376  ) : () } values %QUOTED;
377  %QUOTED = @quoted;
378  weaken($_) for values %QUOTED;
379}
380
3811;
382__END__
383
384=encoding utf-8
385
386=head1 NAME
387
388Sub::Quote - Efficient generation of subroutines via string eval
389
390=head1 SYNOPSIS
391
392 package Silly;
393
394 use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
395
396 quote_sub 'Silly::kitty', q{ print "meow" };
397
398 quote_sub 'Silly::doggy', q{ print "woof" };
399
400 my $sound = 0;
401
402 quote_sub 'Silly::dagron',
403   q{ print ++$sound % 2 ? 'burninate' : 'roar' },
404   { '$sound' => \$sound };
405
406And elsewhere:
407
408 Silly->kitty;  # meow
409 Silly->doggy;  # woof
410 Silly->dagron; # burninate
411 Silly->dagron; # roar
412 Silly->dagron; # burninate
413
414=head1 DESCRIPTION
415
416This package provides performant ways to generate subroutines from strings.
417
418=head1 SUBROUTINES
419
420=head2 quote_sub
421
422 my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
423
424Arguments: ?$name, $code, ?\%captures, ?\%options
425
426C<$name> is the subroutine where the coderef will be installed.
427
428C<$code> is a string that will be turned into code.
429
430C<\%captures> is a hashref of variables that will be made available to the
431code.  The keys should be the full name of the variable to be made available,
432including the sigil.  The values should be references to the values.  The
433variables will contain copies of the values.  See the L</SYNOPSIS>'s
434C<Silly::dagron> for an example using captures.
435
436Exported by default.
437
438=head3 options
439
440=over 2
441
442=item C<no_install>
443
444B<Boolean>.  Set this option to not install the generated coderef into the
445passed subroutine name on undefer.
446
447=item C<no_defer>
448
449B<Boolean>.  Prevents a Sub::Defer wrapper from being generated for the quoted
450sub.  If the sub will most likely be called at some point, setting this is a
451good idea.  For a sub that will most likely be inlined, it is not recommended.
452
453=item C<package>
454
455The package that the quoted sub will be evaluated in.  If not specified, the
456package from sub calling C<quote_sub> will be used.
457
458=item C<hints>
459
460The value of L<< C<$^H> | perlvar/$^H >> to use for the code being evaluated.
461This captures the settings of the L<strict> pragma.  If not specified, the value
462from the calling code will be used.
463
464=item C<warning_bits>
465
466The value of L<< C<${^WARNING_BITS}> | perlvar/${^WARNING_BITS} >> to use for
467the code being evaluated.  This captures the L<warnings> set.  If not specified,
468the warnings from the calling code will be used.
469
470=item C<%^H>
471
472The value of L<< C<%^H> | perlvar/%^H >> to use for the code being evaluated.
473This captures additional pragma settings.  If not specified, the value from the
474calling code will be used if possible (on perl 5.10+).
475
476=item C<attributes>
477
478The L<perlsub/Subroutine Attributes> to apply to the sub generated.  Should be
479specified as an array reference.  The attributes will be applied to both the
480generated sub and the deferred wrapper, if one is used.
481
482=item C<file>
483
484The apparent filename to use for the code being evaluated.
485
486=item C<line>
487
488The apparent line number
489to use for the code being evaluated.
490
491=back
492
493=head2 unquote_sub
494
495 my $coderef = unquote_sub $sub;
496
497Forcibly replace subroutine with actual code.
498
499If $sub is not a quoted sub, this is a no-op.
500
501Exported by default.
502
503=head2 quoted_from_sub
504
505 my $data = quoted_from_sub $sub;
506
507 my ($name, $code, $captures, $compiled_sub) = @$data;
508
509Returns original arguments to quote_sub, plus the compiled version if this
510sub has already been unquoted.
511
512Note that $sub can be either the original quoted version or the compiled
513version for convenience.
514
515Exported by default.
516
517=head2 inlinify
518
519 my $prelude = capture_unroll '$captures', {
520   '$x' => 1,
521   '$y' => 2,
522 }, 4;
523
524 my $inlined_code = inlinify q{
525   my ($x, $y) = @_;
526
527   print $x + $y . "\n";
528 }, '$x, $y', $prelude;
529
530Takes a string of code, a string of arguments, a string of code which acts as a
531"prelude", and a B<Boolean> representing whether or not to localize the
532arguments.
533
534=head2 quotify
535
536 my $quoted_value = quotify $value;
537
538Quotes a single (non-reference) scalar value for use in a code string.  The
539result should reproduce the original value, including strings, undef, integers,
540and floating point numbers.  The resulting floating point numbers (including
541infinites and not a number) should be precisely equal to the original, if
542possible.  The exact format of the resulting number should not be relied on, as
543it may include hex floats or math expressions.
544
545=head2 capture_unroll
546
547 my $prelude = capture_unroll '$captures', {
548   '$x' => 1,
549   '$y' => 2,
550 }, 4;
551
552Arguments: $from, \%captures, $indent
553
554Generates a snippet of code which is suitable to be used as a prelude for
555L</inlinify>.  C<$from> is a string will be used as a hashref in the resulting
556code.  The keys of C<%captures> are the names of the variables and the values
557are ignored.  C<$indent> is the number of spaces to indent the result by.
558
559=head2 qsub
560
561 my $hash = {
562  coderef => qsub q{ print "hello"; },
563  other   => 5,
564 };
565
566Arguments: $code
567
568Works exactly like L</quote_sub>, but includes a prototype to only accept a
569single parameter.  This makes it easier to include in hash structures or lists.
570
571Exported by default.
572
573=head2 sanitize_identifier
574
575 my $var_name = '$variable_for_' . sanitize_identifier('@name');
576 quote_sub qq{ print \$${var_name} }, { $var_name => \$value };
577
578Arguments: $identifier
579
580Sanitizes a value so that it can be used in an identifier.
581
582=head1 ENVIRONMENT
583
584=head2 SUB_QUOTE_DEBUG
585
586Causes code to be output to C<STDERR> before being evaled.  Several forms are
587supported:
588
589=over 4
590
591=item C<1>
592
593All subs will be output.
594
595=item C</foo/>
596
597Subs will be output if their code matches the given regular expression.
598
599=item C<simple_identifier>
600
601Any sub with the given name will be output.
602
603=item C<Full::identifier>
604
605A sub matching the full name will be output.
606
607=item C<Package::Name::>
608
609Any sub in the given package (including anonymous subs) will be output.
610
611=back
612
613=head1 CAVEATS
614
615Much of this is just string-based code-generation, and as a result, a few
616caveats apply.
617
618=head2 return
619
620Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
621Instead of returning from the code you defined in C<quote_sub>, it will return
622from the overall function it is composited into.
623
624So when you pass in:
625
626   quote_sub q{  return 1 if $condition; $morecode }
627
628It might turn up in the intended context as follows:
629
630  sub foo {
631
632    <important code a>
633    do {
634      return 1 if $condition;
635      $morecode
636    };
637    <important code b>
638
639  }
640
641Which will obviously return from foo, when all you meant to do was return from
642the code context in quote_sub and proceed with running important code b.
643
644=head2 pragmas
645
646C<Sub::Quote> preserves the environment of the code creating the
647quoted subs.  This includes the package, strict, warnings, and any
648other lexical pragmas.  This is done by prefixing the code with a
649block that sets up a matching environment.  When inlining C<Sub::Quote>
650subs, care should be taken that user pragmas won't effect the rest
651of the code.
652
653=head1 SUPPORT
654
655Users' IRC: #moose on irc.perl.org
656
657=for :html
658L<(click for instant chatroom login)|http://chat.mibbit.com/#moose@irc.perl.org>
659
660Development and contribution IRC: #web-simple on irc.perl.org
661
662=for :html
663L<(click for instant chatroom login)|http://chat.mibbit.com/#web-simple@irc.perl.org>
664
665Bugtracker: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote>
666
667Git repository: L<git://github.com/moose/Sub-Quote.git>
668
669Git browser: L<https://github.com/moose/Sub-Quote>
670
671=head1 AUTHOR
672
673mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
674
675=head1 CONTRIBUTORS
676
677frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
678
679ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
680
681Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
682
683tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
684
685haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
686
687bluefeet - Aran Deltac (cpan:BLUEFEET) <bluefeet@gmail.com>
688
689ether - Karen Etheridge (cpan:ETHER) <ether@cpan.org>
690
691dolmen - Olivier Mengué (cpan:DOLMEN) <dolmen@cpan.org>
692
693alexbio - Alessandro Ghedini (cpan:ALEXBIO) <alexbio@cpan.org>
694
695getty - Torsten Raudssus (cpan:GETTY) <torsten@raudss.us>
696
697arcanez - Justin Hunter (cpan:ARCANEZ) <justin.d.hunter@gmail.com>
698
699kanashiro - Lucas Kanashiro (cpan:KANASHIRO) <kanashiro.duarte@gmail.com>
700
701djerius - Diab Jerius (cpan:DJERIUS) <djerius@cfa.harvard.edu>
702
703=head1 COPYRIGHT
704
705Copyright (c) 2010-2016 the Sub::Quote L</AUTHOR> and L</CONTRIBUTORS>
706as listed above.
707
708=head1 LICENSE
709
710This library is free software and may be distributed under the same terms
711as perl itself. See L<http://dev.perl.org/licenses/>.
712
713=cut
714