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