[perl #74798] improved useqq compatibility with the pure perl version

Currently for non-useqq, the pure perl and XS output for numbers like
these is different, but XS useqq is new, so try to remain vaguely
compatible.

2 files changed, 64 insertions, 2 deletions

diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs
index 0194a2ce9d..99424c5c9d 100644
--- a/dist/Data-Dumper/Dumper.xs
+++ b/dist/Data-Dumper/Dumper.xs
@@ -119,6 +119,42 @@ TOP:
     return 0;
 }
 
+/* Check that the SV can be represented as a simple decimal integer.
+ *
+ * The perl code does this by matching against /^(?:0|-?[1-9]\d{0,8})\z/
+*/
+static bool
+safe_decimal_number(SV *val) {
+    STRLEN len;
+    const char *p = SvPV(val, len);
+
+    if (len == 1 && *p == '0')
+        return TRUE;
+
+    if (len && *p == '-') {
+        ++p;
+        --len;
+    }
+
+    if (len == 0 || *p < '1' || *p > '9')
+        return FALSE;
+
+    ++p;
+    --len;
+
+    if (len > 8)
+        return FALSE;
+
+    while (len > 0) {
+         /* the perl code checks /\d/ but we don't want unicode digits here */
+         if (*p < '0' || *p > '9')
+             return FALSE;
+         ++p;
+         --len;
+    }
+    return TRUE;
+}
+
 /* count the number of "'"s and "\"s in string */
 static I32
 num_q(const char *s, STRLEN slen)
@@ -1115,6 +1151,15 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
 	}
 #endif
+
+	/* the pure perl and XS non-qq outputs have historically been
+	 * different in this case, but for useqq, let's try to match
+	 * the pure perl code.
+	 * see [perl #74798]
+	 */
+	else if (useqq && safe_decimal_number(val)) {
+	    sv_catsv(retval, val);
+	}
 	else {
         integer_came_from_string:
 	    c = SvPV(val, i);
diff --git a/dist/Data-Dumper/t/dumper.t b/dist/Data-Dumper/t/dumper.t
index 0a3c28c4c1..dbc6d5e096 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 = 420; $XS = 1;
+  $TMAX = 426; $XS = 1;
 }
 else {
   print "### XS extensions not loaded, will NOT run XS tests\n";
-  $TMAX = 210; $XS = 0;
+  $TMAX = 213; $XS = 0;
 }
 
 print "1..$TMAX\n";
@@ -1555,4 +1555,21 @@ EOW
     "\\ octal followed by unicode digit";
   TEST q(Data::Dumper->Dumpxs(["\\x00\\x{0660}"])), '\\ octal followed by unicode digit (xs)'
     if $XS;
+
+  # [perl #118933 - handling of digits
+$WANT = <<'EOW';
+#$VAR1 = 0;
+#$VAR2 = 1;
+#$VAR3 = 90;
+#$VAR4 = -10;
+#$VAR5 = "010";
+#$VAR6 = 112345678;
+#$VAR7 = "1234567890";
+EOW
+  TEST q(Data::Dumper->Dump([0, 1, 90, -10, "010", "112345678", "1234567890" ])),
+    "numbers and number-like scalars";
+
+  TEST q(Data::Dumper->Dumpxs([0, 1, 90, -10, "010", "112345678", "1234567890" ])),
+    "numbers and number-like scalars"
+    if $XS;
 }