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 "e_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