ext/XS-APItest/t/grok.t

   1 #!perl -w
   2 use strict;
   3
   4 use Test::More;
   5 use Config;
   6 use XS::APItest;
   7 use feature 'switch';
   8 no warnings 'experimental::smartmatch';
   9 use constant TRUTH => '0 but true';
  10
  11 # Tests for grok_number. Not yet comprehensive.
  12 foreach my $leader ('', ' ', '  ') {
  13     foreach my $trailer ('', ' ', '  ') {
  14         foreach ((map {"0" x $_} 1 .. 12),
  15                  (map {("0" x $_) . "1"} 0 .. 12),
  16                  (map {"1" . ("0" x $_)} 1 .. 9),
  17                  (map {1 << $_} 0 .. 31),
  18                  (map {1 << $_} 0 .. 31),
  19                  (map {0xFFFFFFFF >> $_} reverse (0 .. 31)),
  20                 ) {
  21             foreach my $sign ('', '-', '+') {
  22                 my $string = $leader . $sign . $_ . $trailer;
  23                 my ($flags, $value) = grok_number($string);
  24                 is($flags & IS_NUMBER_IN_UV, IS_NUMBER_IN_UV,
  25                    "'$string' is a UV");
  26                 is($flags & IS_NUMBER_NEG, $sign eq '-' ? IS_NUMBER_NEG : 0,
  27                    "'$string' sign");
  28                 is($value, abs $string, "value is correct");
  29             }
  30         }
  31
  32         {
  33             my (@UV, @NV);
  34             given ($Config{ivsize}) {
  35                 when (4) {
  36                     @UV = qw(429496729  4294967290 4294967294 4294967295);
  37                     @NV = qw(4294967296 4294967297 4294967300 4294967304);
  38                 }
  39                 when (8) {
  40                     @UV = qw(1844674407370955161  18446744073709551610
  41                              18446744073709551614 18446744073709551615);
  42                     @NV = qw(18446744073709551616 18446744073709551617
  43                              18446744073709551620 18446744073709551624);
  44                 }
  45                 default {
  46                     die "Unknown IV size $_";
  47                 }
  48             }
  49             foreach (@UV) {
  50                 my $string = $leader . $_ . $trailer;
  51                 my ($flags, $value) = grok_number($string);
  52                 is($flags & IS_NUMBER_IN_UV, IS_NUMBER_IN_UV,
  53                    "'$string' is a UV");
  54                 is($value, abs $string, "value is correct");
  55             }
  56             foreach (@NV) {
  57                 my $string = $leader . $_ . $trailer;
  58                 my ($flags, $value) = grok_number($string);
  59                 is($flags & IS_NUMBER_IN_UV, 0, "'$string' is an NV");
  60                 is($value, undef, "value is correct");
  61             }
  62         }
  63
  64         my $string = $leader . TRUTH . $trailer;
  65         my ($flags, $value) = grok_number($string);
  66
  67         if ($string eq TRUTH) {
  68             is($flags & IS_NUMBER_IN_UV, IS_NUMBER_IN_UV, "'$string' is a UV");
  69             is($value, 0);
  70         } else {
  71             is($flags, 0, "'$string' is not a number");
  72             is($value, undef);
  73         }
  74     }
  75 }
  76
  77 # format tests
  78 my @groks =
  79   (
  80    # input, in flags, out uv, out flags
  81    [ "1",    0,                  1,     IS_NUMBER_IN_UV ],
  82    [ "1x",   0,                  undef, 0 ],
  83    [ "1x",   PERL_SCAN_TRAILING, 1,     IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ],
  84    [ "3.1",  0,                  3,     IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT ],
  85    [ "3.1a", 0,                  undef, 0 ],
  86    [ "3.1a", PERL_SCAN_TRAILING, 3,
  87      IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
  88    [ "3e5",  0,                  undef, IS_NUMBER_NOT_INT ],
  89    [ "3e",   0,                  undef, 0 ],
  90    [ "3e",   PERL_SCAN_TRAILING, 3,     IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ],
  91    [ "3e+",  0,                  undef, 0 ],
  92    [ "3e+",  PERL_SCAN_TRAILING, 3,     IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ],
  93    [ "Inf",  0,                  undef,
  94      IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT ],
  95    [ "In",   0,                  undef, 0 ],
  96    [ "Infin",0,                  undef, 0 ],
  97    # this doesn't work and hasn't been needed yet
  98    #[ "Infin",PERL_SCAN_TRAILING, undef,
  99    #  IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
 100    [ "nan",  0,                  undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
 101    # even without PERL_SCAN_TRAILING nan can have weird stuff trailing
 102    [ "nanx", 0,                  undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
 103    [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
 104   );
 105
 106 for my $grok (@groks) {
 107   my ($out_flags, $out_uv) = grok_number_flags($grok->[0], $grok->[1]);
 108   is($out_uv,    $grok->[2], "'$grok->[0]' flags $grok->[1] - check number");
 109   is($out_flags, $grok->[3], "'$grok->[0]' flags $grok->[1] - check flags");
 110 }
 111
 112 my $ATOU_MAX = ~0;
 113
 114 # atou tests
 115 my @atous =
 116   (
 117    # [ input, endsv, out uv, out len ]
 118
 119    # Basic cases.
 120    [ "0",    "",   0,   1 ],
 121    [ "1",    "",   1,   1 ],
 122    [ "2",    "",   2,   1 ],
 123    [ "9",    "",   9,   1 ],
 124    [ "12",   "",   12,  2 ],
 125    [ "123",  "",   123, 3 ],
 126
 127    # Trailing whitespace  is accepted or rejected, depending on endptr.
 128    [ "0 ",   " ",   0,  1 ],
 129    [ "1 ",   " ",   1,  1 ],
 130    [ "2 ",   " ",   2,  1 ],
 131    [ "12 ",  " ",   12, 2 ],
 132
 133    # Trailing garbage is accepted or rejected, depending on endptr.
 134    [ "0x",   "x",   0,  1 ],
 135    [ "1x",   "x",   1,  1 ],
 136    [ "2x",   "x",   2,  1 ],
 137    [ "12x",  "x",   12, 2 ],
 138
 139    # Leading whitespace is failure.
 140    [ " 0",   " 0",  0,  0 ],
 141    [ " 1",   " 1",  0,  0 ],
 142    [ " 12",  " 12", 0,  0 ],
 143
 144    # Leading garbage is outright failure.
 145    [ "x0",   "x0",  0,  0 ],
 146    [ "x1",   "x1",  0,  0 ],
 147    [ "x12",  "x12", 0,  0 ],
 148
 149    # We do not parse decimal point.
 150    [ "12.3",  ".3", 12, 2 ],
 151
 152    # Leading pluses or minuses are no good.
 153    [ "+12", "+12",  0, 0 ],
 154    [ "-12", "-12",  0, 0 ],
 155
 156    # Extra leading zeros cause overflow.
 157    [ "00",   "00",  $ATOU_MAX,  0 ],
 158    [ "01",   "01",  $ATOU_MAX,  0 ],
 159    [ "012",  "012", $ATOU_MAX,  0 ],
 160   );
 161
 162 # Values near overflow point.
 163 if ($Config{uvsize} == 8) {
 164     push @atous,
 165       (
 166        # 32-bit values no problem for 64-bit.
 167        [ "4294967293", "", 4294967293, 10, ],
 168        [ "4294967294", "", 4294967294, 10, ],
 169        [ "4294967295", "", 4294967295, 10, ],
 170        [ "4294967296", "", 4294967296, 10, ],
 171        [ "4294967297", "", 4294967297, 10, ],
 172
 173        # This is well within 64-bit.
 174        [ "9999999999", "", 9999999999, 10, ],
 175
 176        # Values valid up to 64-bit and beyond.
 177        [ "18446744073709551613", "", 18446744073709551613, 20, ],
 178        [ "18446744073709551614", "", 18446744073709551614, 20, ],
 179        [ "18446744073709551615", "", $ATOU_MAX, 20, ],
 180        [ "18446744073709551616", "", $ATOU_MAX, 0, ],
 181        [ "18446744073709551617", "", $ATOU_MAX, 0, ],
 182       );
 183 } elsif ($Config{uvsize} == 4) {
 184     push @atous,
 185       (
 186        # Values valid up to 32-bit and beyond.
 187        [ "4294967293", "", 4294967293, 10, ],
 188        [ "4294967294", "", 4294967294, 10, ],
 189        [ "4294967295", "", $ATOU_MAX, 10, ],
 190        [ "4294967296", "", $ATOU_MAX, 0, ],
 191        [ "4294967297", "", $ATOU_MAX, 0, ],
 192
 193        # Still beyond 32-bit.
 194        [ "4999999999", "", $ATOU_MAX, 0, ],
 195        [ "5678901234", "", $ATOU_MAX, 0, ],
 196        [ "6789012345", "", $ATOU_MAX, 0, ],
 197        [ "7890123456", "", $ATOU_MAX, 0, ],
 198        [ "8901234567", "", $ATOU_MAX, 0, ],
 199        [ "9012345678", "", $ATOU_MAX, 0, ],
 200        [ "9999999999", "", $ATOU_MAX, 0, ],
 201        [ "10000000000", "", $ATOU_MAX, 0, ],
 202        [ "12345678901", "", $ATOU_MAX, 0, ],
 203
 204        # 64-bit values are way beyond.
 205        [ "18446744073709551613", "", $ATOU_MAX, 0, ],
 206        [ "18446744073709551614", "", $ATOU_MAX, 0, ],
 207        [ "18446744073709551615", "", $ATOU_MAX, 0, ],
 208        [ "18446744073709551616", "", $ATOU_MAX, 0, ],
 209        [ "18446744073709551617", "", $ATOU_MAX, 0, ],
 210       );
 211 }
 212
 213 # These will fail to fail once 128/256-bit systems arrive.
 214 push @atous,
 215     (
 216        [ "23456789012345678901", "", $ATOU_MAX, 0 ],
 217        [ "34567890123456789012", "", $ATOU_MAX, 0 ],
 218        [ "98765432109876543210", "", $ATOU_MAX, 0 ],
 219        [ "98765432109876543211", "", $ATOU_MAX, 0 ],
 220        [ "99999999999999999999", "", $ATOU_MAX, 0 ],
 221     );
 222
 223 for my $grok (@atous) {
 224     my $input = $grok->[0];
 225     my $endsv = $grok->[1];
 226
 227     my ($out_uv, $out_len);
 228
 229     # First with endsv.
 230     ($out_uv, $out_len) = grok_atou($input, $endsv);
 231     is($out_uv,  $grok->[2],
 232        "'$input' $endsv - number success (got $out_uv cf $grok->[2])");
 233     ok($grok->[3] <= length $input, "'$input' $endsv - length sanity 1");
 234     unless (length $grok->[1]) {
 235         is($out_len, $grok->[3], "'$input' $endsv - length sanity 2");
 236     } # else { ... } ?
 237     if ($out_len) {
 238         is($endsv, substr($input, $out_len),
 239            "'$input' $endsv - length sanity 3");
 240     }
 241
 242     # Then without endsv (undef == NULL).
 243     ($out_uv, $out_len) = grok_atou($input, undef);
 244     if (length $grok->[1]) {
 245         if ($grok->[2] == $ATOU_MAX) {
 246             is($out_uv,  $ATOU_MAX, "'$input' undef - number overflow");
 247         } else {
 248             is($out_uv,  0, "'$input' undef - number zero");
 249         }
 250     } else {
 251         is($out_uv,  $grok->[2],
 252            "'$input' undef - number success (got $out_uv cf $grok->[2])");
 253     }
 254 }
 255
 256 done_testing();