diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm index b6616ca..46aa992 100644 --- a/lib/Sub/Quote.pm +++ b/lib/Sub/Quote.pm @@ -13,11 +13,8 @@ use Scalar::Util qw(weaken); use Exporter qw(import); use Carp qw(croak); BEGIN { our @CARP_NOT = qw(Sub::Defer) } -use B (); BEGIN { *_HAVE_IS_UTF8 = defined &utf8::is_utf8 ? sub(){1} : sub(){0}; - *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0}; - *_BAD_BACKSLASH_ESCAPE = _HAVE_PERLSTRING() && "$]" == 5.010_000 ? sub(){1} : sub(){0}; *_HAVE_HEX_FLOAT = !$ENV{SUB_QUOTE_NO_HEX_FLOAT} && "$]" >= 5.022 ? sub(){1} : sub(){0}; # This may not be perfect, as we can't tell the format purely from the size @@ -35,9 +32,51 @@ BEGIN { ; my $precision = int( log(2)/log(10)*$nvmantbits ); - *_NVSIZE = sub(){$nvsize}; - *_NVMANTBITS = sub(){$nvmantbits}; - *_FLOAT_PRECISION = sub(){$precision}; + *_NVSIZE = sub(){ $nvsize }; + *_NVMANTBITS = sub(){ $nvmantbits }; + *_FLOAT_PRECISION = sub(){ $precision }; + + local $@; + # if B is already loaded, just use its perlstring + if ("$]" >= 5.008_000 && "$]" != 5.010_000 && defined &B::perlstring) { + *_perlstring = \&B::perlstring; + } + # XString is smaller than B, so prefer to use it. Buggy until 0.003. + elsif (eval { require XString; XString->VERSION(0.003) }) { + *_perlstring = \&XString::perlstring; + } + # B::perlstring in perl 5.10 handles escaping incorrectly on utf8 strings + elsif ("$]" == 5.010_000) { + my %escape = ( + (map +(chr($_) => sprintf '\x%02x', $_), 0 .. 0x31, 0x7f), + "\t" => "\\t", + "\n" => "\\n", + "\r" => "\\r", + "\f" => "\\f", + "\b" => "\\b", + "\a" => "\\a", + "\e" => "\\e", + (map +($_ => "\\$_"), qw(" \ $ @)), + ); + *_perlstring = sub { + my $value = shift; + $value =~ s{(["\$\@\\[:cntrl:]]|[^\x00-\x7f])}{ + $escape{$1} || sprintf('\x{%x}', ord($1)) + }ge; + qq["$value"]; + }; + } + elsif ("$]" >= 5.008_000 && eval { require B; 1 } && defined &B::perlstring ) { + *_perlstring = \&B::perlstring; + } + # on perl 5.6, perlstring is not available. quotemeta will mostly serve as a + # replacement. it quotes just by adding lots of backslashes though. if a + # utf8 string was written out directly as bytes, it wouldn't get interpreted + # correctly if not under 'use utf8'. this is mostly a theoretical concern, + # but enough to stick with perlstring when possible. + else { + *_perlstring = sub { qq["\Q$_[0]\E"] }; + } } our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub); @@ -45,21 +84,6 @@ our @EXPORT_OK = qw(quotify capture_unroll inlinify sanitize_identifier); our %QUOTED; -my %escape; -if (_BAD_BACKSLASH_ESCAPE) { - %escape = ( - (map +(chr($_) => sprintf '\x%02x', $_), 0 .. 0x31, 0x7f), - "\t" => "\\t", - "\n" => "\\n", - "\r" => "\\r", - "\f" => "\\f", - "\b" => "\\b", - "\a" => "\\a", - "\e" => "\\e", - (map +($_ => "\\$_"), qw(" \ $ @)), - ); -} - sub quotify { my $value = $_[0]; no warnings 'numeric'; @@ -116,14 +140,7 @@ sub quotify { } ) : !length($value) && length( (my $dummy2 = '') & $value ) ? '(!1)' # false - : _BAD_BACKSLASH_ESCAPE && _HAVE_IS_UTF8 && utf8::is_utf8($value) ? do { - $value =~ s/(["\$\@\\[:cntrl:]]|[^\x00-\x7f])/ - $escape{$1} || sprintf('\x{%x}', ord($1)) - /ge; - qq["$value"]; - } - : _HAVE_PERLSTRING ? B::perlstring($value) - : qq["\Q$value\E"]; + : _perlstring($value); } sub sanitize_identifier { diff --git a/t/quotify-5.6.t b/t/quotify-5.6.t deleted file mode 100644 index c870f1e..0000000 --- a/t/quotify-5.6.t +++ /dev/null @@ -1,12 +0,0 @@ -use strict; -use warnings; -no warnings 'once'; -use B; -BEGIN { - local $utf8::{is_utf8}; - local $B::{perlstring}; - require Sub::Quote; -} -die "Unable to disable utf8::is_utf8 and B::perlstring for testing" - unless !Sub::Quote::_HAVE_IS_UTF8 && ! Sub::Quote::_HAVE_PERLSTRING; -do './t/quotify.t' or die $@ || $!; diff --git a/t/quotify-no-hex.t b/t/quotify-no-hex.t index 61eac5d..53ef970 100644 --- a/t/quotify-no-hex.t +++ b/t/quotify-no-hex.t @@ -1,5 +1,5 @@ use strict; use warnings; no warnings 'once'; -$::SUB_QUOTE_NO_HEX_FLOAT = 1; +unshift @ARGV, '--no-hex'; do './t/quotify.t' or die $@ || $!; diff --git a/t/quotify.t b/t/quotify.t index 07b268c..ac545ea 100644 --- a/t/quotify.t +++ b/t/quotify.t @@ -1,20 +1,64 @@ use strict; use warnings; no warnings 'once'; -use Test::More; -use Data::Dumper; -use B; -my $PERFECT; +my %opts; BEGIN { - $PERFECT = grep $_ eq '--perfect', @ARGV; - my $no_hex = grep $_ eq '--no-hex', @ARGV; - $ENV{SUB_QUOTE_NO_HEX_FLOAT} = ($no_hex || $::SUB_QUOTE_NO_HEX_FLOAT) ? 1 : 0; + for my $arg (@ARGV) { + if ($arg =~ /\A--(perfect|5_10_0|5_6|no-hex|b-perlstring|no-xstring)\z/) { + $opts{$1} = 1; + } + else { + die "Invalid option: $arg\n"; + } + } + + $ENV{SUB_QUOTE_NO_HEX_FLOAT} = 0+!!$opts{'no-hex'}; + + { + my $v; + + $opts{'5_6'} || $opts{'5_10_0'} || $opts{'no-xstring'} and + (eval { require XString }), + (local $XString::VERSION = '0.001'), + ; + + $opts{'5_6'} and + (require B), + (local $B::{perlstring}), + (local $utf8::{is_utf8}), + ($v = 5.006), + ; + + $opts{'5_10_0'} and + ($v = 5.010000), + ; + + $opts{'b-perlstring'} and + (require B), + ; + + $v and + ($v = sprintf "%.6f", $v), + (my $t = $v + 0), + (Internals::SvREADONLY($], 0)), + (local $] = $v), + (Internals::SvREADONLY($], 1)), + ; + + require Sub::Quote; + } + + Internals::SvREADONLY($], 1); } use Sub::Quote qw( quotify ); +use Test::More; +use Data::Dumper; +use B; + use constant HAVE_UTF8 => Sub::Quote::_HAVE_IS_UTF8; use constant FLOAT_PRECISION => Sub::Quote::_FLOAT_PRECISION; use constant HAVE_HEX_FLOAT => Sub::Quote::_HAVE_HEX_FLOAT; @@ -229,7 +273,7 @@ for my $value (_uniq @quotify) { if (is_numeric($value)) { if ($value == $value) { my $todo; - if (!$PERFECT && !HAVE_HEX_FLOAT && $check_value != $value && is_float($value)) { + if (!$opts{perfect} && !HAVE_HEX_FLOAT && $check_value != $value && is_float($value)) { my $diff = abs($check_value - $value); my $accuracy = abs($value)/$diff; my $precision = FLOAT_PRECISION + 1; diff --git a/xt/quotify-5.10.0.t b/xt/quotify-5.10.0.t new file mode 100644 index 0000000..941b86c --- /dev/null +++ b/xt/quotify-5.10.0.t @@ -0,0 +1,5 @@ +use strict; +use warnings; +no warnings 'once'; +unshift @ARGV, '--5_10_0'; +do './t/quotify.t' or die $@ || $!; diff --git a/xt/quotify-5.6.t b/xt/quotify-5.6.t new file mode 100644 index 0000000..8390e85 --- /dev/null +++ b/xt/quotify-5.6.t @@ -0,0 +1,5 @@ +use strict; +use warnings; +no warnings 'once'; +unshift @ARGV, '--5_6'; +do './t/quotify.t' or die $@ || $!; diff --git a/xt/quotify-b.t b/xt/quotify-b.t new file mode 100644 index 0000000..cf5decd --- /dev/null +++ b/xt/quotify-b.t @@ -0,0 +1,5 @@ +use strict; +use warnings; +no warnings 'once'; +unshift @ARGV, '--b-perlstring'; +do './t/quotify.t' or die $@ || $!; diff --git a/xt/quotify-no-xstring.t b/xt/quotify-no-xstring.t new file mode 100644 index 0000000..6a930b6 --- /dev/null +++ b/xt/quotify-no-xstring.t @@ -0,0 +1,5 @@ +use strict; +use warnings; +no warnings 'once'; +unshift @ARGV, '--no-xstring'; +do './t/quotify.t' or die $@ || $!;