Some tests for Perl_grok_number().

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

diff --git a/MANIFEST b/MANIFEST
index 4a5abf9..d0b8b16 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3326,6 +3326,7 @@ ext/XS-APItest-KeywordRPN/t/swaptwostmts.t        test recursive descent statement pars
 ext/XS-APItest/Makefile.PL     XS::APItest extension
 ext/XS-APItest/MANIFEST                XS::APItest extension
 ext/XS-APItest/notcore.c       Test API functions when PERL_CORE is not defined
 ext/XS-APItest/Makefile.PL     XS::APItest extension
 ext/XS-APItest/MANIFEST                XS::APItest extension
 ext/XS-APItest/notcore.c       Test API functions when PERL_CORE is not defined

+ext/XS-APItest/numeric.xs      XS::APItest wrappers for numeric.c

 ext/XS-APItest/README          XS::APItest extension
 ext/XS-APItest/t/BHK.pm                Helper for ./blockhooks.t
 ext/XS-APItest/t/blockhooks-csc.t      XS::APItest: more tests for PL_blockhooks
 ext/XS-APItest/README          XS::APItest extension
 ext/XS-APItest/t/BHK.pm                Helper for ./blockhooks.t
 ext/XS-APItest/t/blockhooks-csc.t      XS::APItest: more tests for PL_blockhooks


@@ -3335,6 +3336,7 @@ ext/XS-APItest/t/caller.t XS::APItest: tests for caller_cx
 ext/XS-APItest/t/call.t                XS::APItest extension
 ext/XS-APItest/t/copyhints.t   test hv_copy_hints_hv() API
 ext/XS-APItest/t/exception.t   XS::APItest extension
 ext/XS-APItest/t/call.t                XS::APItest extension
 ext/XS-APItest/t/copyhints.t   test hv_copy_hints_hv() API
 ext/XS-APItest/t/exception.t   XS::APItest extension

+ext/XS-APItest/t/grok.t                XS::APItest: tests for grok* functions

 ext/XS-APItest/t/hash.t                XS::APItest: tests for hash related APIs
 ext/XS-APItest/t/Markers.pm    Helper for ./blockhooks.t
 ext/XS-APItest/t/my_cxt.t      XS::APItest: test MY_CXT interface
 ext/XS-APItest/t/hash.t                XS::APItest: tests for hash related APIs
 ext/XS-APItest/t/Markers.pm    Helper for ./blockhooks.t
 ext/XS-APItest/t/my_cxt.t      XS::APItest: test MY_CXT interface

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index c6cac13..48542dd 100644 (file)
--- 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"
 
 
 #include "const-c.inc"
 

-MODULE = XS::APItest:Hash              PACKAGE = XS::APItest::Hash
+MODULE = XS::APItest           PACKAGE = XS::APItest

 
 INCLUDE: const-xs.inc
 
 
 INCLUDE: const-xs.inc
 

+INCLUDE: numeric.xs
+
+MODULE = XS::APItest:Hash              PACKAGE = XS::APItest::Hash
+

 void
 rot13_hash(hash)
        HV *hash
 void
 rot13_hash(hash)
        HV *hash

diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index bccf38f..340fc7e 100644 (file)
--- 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
     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"]}],
               );
 
              {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 (file)
index 0000000..b06258d
--- /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 (file)
index 0000000..2d2d192
--- /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();