use XString rather than B when possible

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,31 +32,58 @@ 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);
 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 {

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 $@ || $!;

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;

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 $@ || $!;

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 $@ || $!;

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 $@ || $!;

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 $@ || $!;