Some tests for Perl_grok_number().

Not yet comprehensive - only tests the integer conversion code paths.

4 files changed, 102 insertions, 2 deletions

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index c6cac13640..48542dd6d0 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -374,10 +374,14 @@ my_rpeep (pTHX_ OP *o)
 
 #include "const-c.inc"
 
-MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
+MODULE = XS::APItest		PACKAGE = XS::APItest
 
 INCLUDE: const-xs.inc
 
+INCLUDE: numeric.xs
+
+MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
+
 void
 rot13_hash(hash)
 	HV *hash
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index bccf38fef8..340fc7e910 100644
--- a/ext/XS-APItest/Makefile.PL
+++ b/ext/XS-APItest/Makefile.PL
@@ -22,7 +22,11 @@ WriteConstants(
     NAMES => [qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE
 		 HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV
 		 G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS
-		 G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL),
+		 G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL
+		 IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX
+		 IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY
+		 IS_NUMBER_NAN
+		),
 	      {name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]}],
 	       );
 
diff --git a/ext/XS-APItest/numeric.xs b/ext/XS-APItest/numeric.xs
new file mode 100644
index 0000000000..b06258d3c1
--- /dev/null
+++ b/ext/XS-APItest/numeric.xs
@@ -0,0 +1,16 @@
+MODULE = XS::APItest		PACKAGE = XS::APItest::numeric
+
+void
+grok_number(number)
+	SV *number
+    PREINIT:
+	STRLEN len;
+	const char *pv = SvPV(number, len);
+	UV value;
+	int result;
+    PPCODE:
+	EXTEND(SP,2);
+	result = grok_number(pv, len, &value);
+	PUSHs(sv_2mortal(newSViv(result)));
+	if (result & IS_NUMBER_IN_UV)
+	    PUSHs(sv_2mortal(newSVuv(value)));
diff --git a/ext/XS-APItest/t/grok.t b/ext/XS-APItest/t/grok.t
new file mode 100644
index 0000000000..2d2d192c7d
--- /dev/null
+++ b/ext/XS-APItest/t/grok.t
@@ -0,0 +1,76 @@
+#!perl -w
+use strict;
+
+use Test::More;
+use Config;
+use XS::APItest;
+use feature 'switch';
+use constant TRUTH => '0 but true';
+
+# Tests for grok_number. Not yet comprehensive.
+foreach my $leader ('', ' ', '  ') {
+    foreach my $trailer ('', ' ', '  ') {
+	foreach ((map {"0" x $_} 1 .. 12),
+		 (map {("0" x $_) . "1"} 0 .. 12),
+		 (map {"1" . ("0" x $_)} 1 .. 9),
+		 (map {1 << $_} 0 .. 31),
+		 (map {1 << $_} 0 .. 31),
+		 (map {0xFFFFFFFF >> $_} reverse (0 .. 31)),
+		) {
+	    foreach my $sign ('', '-', '+') {
+		my $string = $leader . $sign . $_ . $trailer;
+		my ($flags, $value) = grok_number($string);
+		is($flags & IS_NUMBER_IN_UV, IS_NUMBER_IN_UV,
+		   "'$string' is a UV");
+		is($flags & IS_NUMBER_NEG, $sign eq '-' ? IS_NUMBER_NEG : 0,
+		   "'$string' sign");
+		is($value, abs $string, "value is correct");
+	    }
+	}
+
+	{
+	    my (@UV, @NV);
+	    given ($Config{ivsize}) {
+		when (4) {
+		    @UV = qw(429496729  4294967290 4294967294 4294967295);
+		    @NV = qw(4294967296 4294967297 4294967300 4294967304);
+		}
+		when (8) {
+		    @UV = qw(1844674407370955161  18446744073709551610
+			     18446744073709551614 18446744073709551615);
+		    @NV = qw(18446744073709551616 18446744073709551617
+			     18446744073709551620 18446744073709551624);
+		}
+		default {
+		    die "Unknown IV size $_";
+		}
+	    }
+	    foreach (@UV) {
+		my $string = $leader . $_ . $trailer;
+		my ($flags, $value) = grok_number($string);
+		is($flags & IS_NUMBER_IN_UV, IS_NUMBER_IN_UV,
+		   "'$string' is a UV");
+		is($value, abs $string, "value is correct");
+	    }
+	    foreach (@NV) {
+		my $string = $leader . $_ . $trailer;
+		my ($flags, $value) = grok_number($string);
+		is($flags & IS_NUMBER_IN_UV, 0, "'$string' is an NV");
+		is($value, undef, "value is correct");
+	    }
+	}
+
+	my $string = $leader . TRUTH . $trailer;
+	my ($flags, $value) = grok_number($string);
+
+	if ($string eq TRUTH) {
+	    is($flags & IS_NUMBER_IN_UV, IS_NUMBER_IN_UV, "'$string' is a UV");
+	    is($value, 0);
+	} else {
+	    is($flags, 0, "'$string' is not a number");
+	    is($value, undef);
+	}
+    }
+}
+
+done_testing();