[perl #101162] DD support for vstrings

This commit adds support for vstrings to Data::Dumper, in both Perl
and XS implementations.

Since the actual vstring cannot be obtained from pure Perl, there is a
new _vstring XS function that the PP implementation uses, falling back
to sprintf "%vd" if XS is not available.  The former dumps v1.2_3 cor-
rectly, while the latter produces v1.23.  (I could make it use B to
extract the correct string, but XS is likely to be unavailable in
those circumstances where B is also unavailable [i.e., miniperl], so
it didn’t seem worth the effort.)

Some Perl versions (read: *all* released versions as of this message)
let vstring magic linger too long on strings that have been modified.
So that is checked for, but the bug is probed at compile time and the
code is #ifdeffed or use-constanted out when the bug is not present.

Due to the definition of the _bad_vsmg constant, I had to move
XSLoader::load into the BEGIN block.  Since I was putting it there,
I combined it, the $Useperl = 1 and the eval{} into one statement,
for speed.

Since I was putting XSLoader::load into a BEGIN block, $VERSION needed
to be in one, too.

3 files changed, 82 insertions, 8 deletions

diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm
index c208266ffc..e3b7dbfb4c 100644
--- a/dist/Data-Dumper/Dumper.pm
+++ b/dist/Data-Dumper/Dumper.pm
@@ -9,7 +9,9 @@
 
 package Data::Dumper;
 
-$VERSION = '2.135_02'; # Don't forget to set version and release date in POD!
+BEGIN {
+    $VERSION = '2.135_02'; # Don't forget to set version and release
+}			   # date in POD!
 
 #$| = 1;
 
@@ -29,12 +31,11 @@ BEGIN {
     # toggled on load failure.
     eval {
 	require XSLoader;
-    };
-    $Useperl = 1 if $@;
+    }
+    ? XSLoader::load( 'Data::Dumper' )
+    : ($Useperl = 1);
 }
 
-XSLoader::load( 'Data::Dumper' ) unless $Useperl;
-
 # module vars and their defaults
 $Indent     = 2         unless defined $Indent;
 $Purity     = 0         unless defined $Purity;
@@ -255,6 +256,10 @@ sub _quote {
     return  "'" . $val .  "'";
 }
 
+# Old Perls (5.14-) have trouble resetting vstring magic when it is no
+# longer valid.
+use constant _bad_vsmg => defined &_vstring && (_vstring(~v0)||'') eq "v0";
+
 #
 # twist, toil and turn;
 # and recurse, of course.
@@ -370,7 +375,8 @@ sub _dump {
         $pat =~ s,/,\\/,g;
         $out .= "qr/$pat/";
     }
-    elsif ($realtype eq 'SCALAR' || $realtype eq 'REF') {
+    elsif ($realtype eq 'SCALAR' || $realtype eq 'REF'
+	|| $realtype eq 'VSTRING') {
       if ($realpack) {
 	$out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
       }
@@ -475,6 +481,7 @@ sub _dump {
   else {                                 # simple scalar
 
     my $ref = \$_[1];
+    my $v;
     # first, catalog the scalar
     if ($name ne '') {
       $id = format_refaddr($ref);
@@ -520,6 +527,14 @@ sub _dump {
     elsif (!defined($val)) {
       $out .= "undef";
     }
+    elsif (defined &_vstring and $v = _vstring($val)
+	and !_bad_vsmg || eval $v eq $val) {
+      $out .= $v;
+    }
+    elsif (!defined &_vstring
+       and ref \$val eq 'VSTRING' || eval{Scalar::Util::isvstring($val)}) {
+      $out .= sprintf "%vd", $val;
+    }
     elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number
       $out .= $val;
     }
diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs
index 4bd3c7e6c1..b6da680419 100644
--- a/dist/Data-Dumper/Dumper.xs
+++ b/dist/Data-Dumper/Dumper.xs
@@ -857,6 +857,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
     }
     else {
 	STRLEN i;
+	const MAGIC *mg;
 	
 	if (namelen) {
 #ifdef DD_USE_OLD_ID_FORMAT
@@ -998,6 +999,20 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	else if (val == &PL_sv_undef || !SvOK(val)) {
 	    sv_catpvn(retval, "undef", 5);
 	}
+#ifdef SvVOK
+	else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
+# ifndef PL_vtbl_vstring
+	    SV * const vecsv = sv_newmortal();
+#  if PERL_VERSION < 10
+	    scan_vstring(mg->mg_ptr, vecsv);
+#  else
+	    scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
+#  endif
+	    if (!sv_eq(vecsv, val)) goto integer_came_from_string;
+# endif
+	    sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
+	}
+#endif
 	else {
         integer_came_from_string:
 	    c = SvPV(val, i);
@@ -1261,3 +1276,21 @@ Data_Dumper_Dumpxs(href, ...)
 	    if (gimme == G_SCALAR)
 		XPUSHs(sv_2mortal(retval));
 	}
+
+SV *
+Data_Dumper__vstring(sv)
+	SV	*sv;
+	PROTOTYPE: $
+	CODE:
+	{
+#ifdef SvVOK
+	    const MAGIC *mg;
+	    RETVAL =
+		SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
+		 ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
+		 : &PL_sv_undef;
+#else
+	    RETVAL = &PL_sv_undef;
+#endif
+	}
+	OUTPUT: RETVAL
diff --git a/dist/Data-Dumper/t/dumper.t b/dist/Data-Dumper/t/dumper.t
index 915d46d0dd..4b088b85f8 100644
--- a/dist/Data-Dumper/t/dumper.t
+++ b/dist/Data-Dumper/t/dumper.t
@@ -83,11 +83,11 @@ sub SKIP_TEST {
 $Data::Dumper::Useperl = 1;
 if (defined &Data::Dumper::Dumpxs) {
   print "### XS extension loaded, will run XS tests\n";
-  $TMAX = 378; $XS = 1;
+  $TMAX = 384; $XS = 1;
 }
 else {
   print "### XS extensions not loaded, will NOT run XS tests\n";
-  $TMAX = 189; $XS = 0;
+  $TMAX = 192; $XS = 0;
 }
 
 print "1..$TMAX\n";
@@ -1466,3 +1466,29 @@ EOT
   TEST q(Dumper($foo)), 'All latin1 characters with utf8 flag including a wide character';
   for (1..3) { print "not ok " . (++$TNUM) . " # TODO NYI\n" if $XS } # TEST q(Data::Dumper::DumperX($foo)) if $XS;
 }
+
+############# 378
+{
+  # If XS cannot load, the pure-Perl version cannot deparse vstrings with
+  # underscores properly.  In 5.8.0, vstrings are just strings.
+  $WANT = $] > 5.0080001 ? $XS ? <<'EOT' : <<'EOV' : <<'EOU';
+#$a = \v65.66.67;
+#$b = \v65.66.067;
+#$c = \v65.66.6_7;
+#$d = \'ABC';
+EOT
+#$a = \v65.66.67;
+#$b = \v65.66.67;
+#$c = \v65.66.67;
+#$d = \'ABC';
+EOV
+#$a = \'ABC';
+#$b = \'ABC';
+#$c = \'ABC';
+#$d = \'ABC';
+EOU
+  @::_v = (\v65.66.67, \v65.66.067, \v65.66.6_7, \~v190.189.188);
+  TEST q(Data::Dumper->Dump(\@::_v, [qw(a b c d)])), 'vstrings';
+  TEST q(Data::Dumper->Dumpxs(\@::_v, [qw(a b c d)])), 'xs vstrings'
+    if $XS;
+}