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 ( 73 # input, in flags, out uv, out flags 74 [ "1", 0, 1, IS_NUMBER_IN_UV ], 75 [ "1x", 0, undef, 0 ], 76 [ "1x", PERL_SCAN_TRAILING, 1, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], 77 [ "3.1", 0, 3, IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT ], 78 [ "3.1a", 0, undef, 0 ], 79 [ "3.1a", PERL_SCAN_TRAILING, 3, 80 IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], 81 [ "3e5", 0, undef, IS_NUMBER_NOT_INT ], 82 [ "3e", 0, undef, 0 ], 83 [ "3e", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], 84 [ "3e+", 0, undef, 0 ], 85 [ "3e+", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], 86 [ "Inf", 0, undef, 87 IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT ], 88 [ "In", 0, undef, 0 ], 89 [ "Infin",0, undef, IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], 90 # this doesn't work and hasn't been needed yet 91 #[ "Infin",PERL_SCAN_TRAILING, undef, 92 # IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], 93 [ "nan", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], 94 # even without PERL_SCAN_TRAILING nan can have weird stuff trailing 95 [ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], 96 [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], 97 ); 98 99my $non_ieee_fp = ($Config{doublekind} == 9 || 100 $Config{doublekind} == 10 || 101 $Config{doublekind} == 11); 102 103if ($non_ieee_fp) { 104 @groks = grep { $_->[0] !~ /^(?:inf|nan)/i } @groks; 105} 106 107for my $grok (@groks) { 108 my ($out_flags, $out_uv) = grok_number_flags($grok->[0], $grok->[1]); 109 is($out_uv, $grok->[2], "'$grok->[0]' flags $grok->[1] - check number"); 110 is($out_flags, $grok->[3], "'$grok->[0]' flags $grok->[1] - check flags"); 111} 112 113my $ATOU_MAX = ~0; 114 115# atou tests 116my @atous = 117 ( 118 # [ input, endsv, out uv, out len ] 119 120 # Basic cases. 121 [ "0", "", 0, 1 ], 122 [ "1", "", 1, 1 ], 123 [ "2", "", 2, 1 ], 124 [ "9", "", 9, 1 ], 125 [ "12", "", 12, 2 ], 126 [ "123", "", 123, 3 ], 127 128 # Trailing whitespace is accepted or rejected, depending on endptr. 129 [ "0 ", " ", 0, 1 ], 130 [ "1 ", " ", 1, 1 ], 131 [ "2 ", " ", 2, 1 ], 132 [ "12 ", " ", 12, 2 ], 133 134 # Trailing garbage is accepted or rejected, depending on endptr. 135 [ "0x", "x", 0, 1 ], 136 [ "1x", "x", 1, 1 ], 137 [ "2x", "x", 2, 1 ], 138 [ "12x", "x", 12, 2 ], 139 140 # Leading whitespace is failure. 141 [ " 0", undef, 0, 0 ], 142 [ " 1", undef, 0, 0 ], 143 [ " 12", undef, 0, 0 ], 144 145 # Leading garbage is outright failure. 146 [ "x0", undef, 0, 0 ], 147 [ "x1", undef, 0, 0 ], 148 [ "x12", undef, 0, 0 ], 149 150 # We do not parse decimal point. 151 [ "12.3", ".3", 12, 2 ], 152 153 # Leading pluses or minuses are no good. 154 [ "+12", undef, 0, 0 ], 155 [ "-12", undef, 0, 0 ], 156 157 # Extra leading zeros are no good. 158 [ "00", undef, $ATOU_MAX, 0 ], 159 [ "01", undef, $ATOU_MAX, 0 ], 160 [ "012", undef, $ATOU_MAX, 0 ], 161 ); 162 163# Values near overflow point. 164if ($Config{uvsize} == 8) { 165 push @atous, 166 ( 167 # 32-bit values no problem for 64-bit. 168 [ "4294967293", "", 4294967293, 10, ], 169 [ "4294967294", "", 4294967294, 10, ], 170 [ "4294967295", "", 4294967295, 10, ], 171 [ "4294967296", "", 4294967296, 10, ], 172 [ "4294967297", "", 4294967297, 10, ], 173 174 # This is well within 64-bit. 175 [ "9999999999", "", 9999999999, 10, ], 176 177 # Values valid up to 64-bit, failing beyond. 178 [ "18446744073709551613", "", 18446744073709551613, 20, ], 179 [ "18446744073709551614", "", 18446744073709551614, 20, ], 180 [ "18446744073709551615", "", $ATOU_MAX, 20, ], 181 [ "18446744073709551616", undef, $ATOU_MAX, 0, ], 182 [ "18446744073709551617", undef, $ATOU_MAX, 0, ], 183 ); 184} elsif ($Config{uvsize} == 4) { 185 push @atous, 186 ( 187 # Values valid up to 32-bit, failing beyond. 188 [ "4294967293", "", 4294967293, 10, ], 189 [ "4294967294", "", 4294967294, 10, ], 190 [ "4294967295", "", $ATOU_MAX, 10, ], 191 [ "4294967296", undef, $ATOU_MAX, 0, ], 192 [ "4294967297", undef, $ATOU_MAX, 0, ], 193 194 # Still beyond 32-bit. 195 [ "4999999999", undef, $ATOU_MAX, 0, ], 196 [ "5678901234", undef, $ATOU_MAX, 0, ], 197 [ "6789012345", undef, $ATOU_MAX, 0, ], 198 [ "7890123456", undef, $ATOU_MAX, 0, ], 199 [ "8901234567", undef, $ATOU_MAX, 0, ], 200 [ "9012345678", undef, $ATOU_MAX, 0, ], 201 [ "9999999999", undef, $ATOU_MAX, 0, ], 202 [ "10000000000", undef, $ATOU_MAX, 0, ], 203 [ "12345678901", undef, $ATOU_MAX, 0, ], 204 205 # 64-bit values are way beyond. 206 [ "18446744073709551613", undef, $ATOU_MAX, 0, ], 207 [ "18446744073709551614", undef, $ATOU_MAX, 0, ], 208 [ "18446744073709551615", undef, $ATOU_MAX, 0, ], 209 [ "18446744073709551616", undef, $ATOU_MAX, 0, ], 210 [ "18446744073709551617", undef, $ATOU_MAX, 0, ], 211 ); 212} 213 214# These will fail to fail once 128/256-bit systems arrive. 215push @atous, 216 ( 217 [ "23456789012345678901", undef, $ATOU_MAX, 0 ], 218 [ "34567890123456789012", undef, $ATOU_MAX, 0 ], 219 [ "98765432109876543210", undef, $ATOU_MAX, 0 ], 220 [ "98765432109876543211", undef, $ATOU_MAX, 0 ], 221 [ "99999999999999999999", undef, $ATOU_MAX, 0 ], 222 ); 223 224for my $grok (@atous) { 225 my $input = $grok->[0]; 226 my $endsv = $grok->[1]; 227 my $expect_ok = defined $endsv; 228 my $strict_ok = $expect_ok && $endsv eq ''; 229 230 my ($ok, $out_uv, $out_len); 231 232 # First with endsv. 233 ($ok, $out_uv, $out_len) = grok_atoUV($input, $endsv); 234 is($expect_ok, $ok, sprintf "'$input' expected %s, got %s", 235 ($expect_ok ? 'success' : 'failure'), 236 ($ok ? 'success' : 'failure'), 237 ); 238 if ($expect_ok) { 239 is($expect_ok, $ok, "'$input' expect success"); 240 is($out_uv, $grok->[2], 241 "'$input' $endsv - number success (got $out_uv cf $grok->[2])"); 242 ok($grok->[3] <= length $input, "'$input' $endsv - length sanity 1"); 243 unless (length $grok->[1]) { 244 is($out_len, $grok->[3], "'$input' $endsv - length sanity 2"); 245 } # else { ... } ? 246 if ($out_len) { 247 is($endsv, substr($input, $out_len), 248 "'$input' $endsv - length sanity 3"); 249 } 250 } else { 251 is($expect_ok, $ok, "'$input' expect failure"); 252 is(0xdeadbeef, $out_uv, "'$input' on failure expect value unchanged"); 253 } 254 255 # Then without endsv (undef == NULL). 256 ($ok, $out_uv, $out_len) = grok_atoUV($input, undef); 257 if ($strict_ok) { 258 is($strict_ok, $ok, "'$input' expect strict success"); 259 is($out_uv, $grok->[2], 260 "'$input' $endsv - strict number success (got $out_uv cf $grok->[2])"); 261 } else { 262 is($strict_ok, $ok, "'$input' expect strict failure"); 263 is(0xdeadbeef, $out_uv, "'$input' on strict failure expect value unchanged"); 264 } 265} 266 267done_testing(); 268