#!perl -w
use strict;
use Test::More;
use Config;
use XS::APItest;
use feature 'switch';
no warnings 'experimental::smartmatch';
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);
}
}
}
# format tests
my @groks =
(
# input, in flags, out uv, out flags
[ "1", 0, 1, IS_NUMBER_IN_UV ],
[ "1x", 0, undef, 0 ],
[ "1x", PERL_SCAN_TRAILING, 1, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ],
[ "3.1", 0, 3, IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT ],
[ "3.1a", 0, undef, 0 ],
[ "3.1a", PERL_SCAN_TRAILING, 3,
IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
[ "3e5", 0, undef, IS_NUMBER_NOT_INT ],
[ "3e", 0, undef, 0 ],
[ "3e", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ],
[ "3e+", 0, undef, 0 ],
[ "3e+", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ],
[ "Inf", 0, undef,
IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT ],
[ "In", 0, undef, 0 ],
[ "Infin",0, undef, IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
# this doesn't work and hasn't been needed yet
#[ "Infin",PERL_SCAN_TRAILING, undef,
# IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
[ "nan", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
# even without PERL_SCAN_TRAILING nan can have weird stuff trailing
[ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
[ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
);
for my $grok (@groks) {
my ($out_flags, $out_uv) = grok_number_flags($grok->[0], $grok->[1]);
is($out_uv, $grok->[2], "'$grok->[0]' flags $grok->[1] - check number");
is($out_flags, $grok->[3], "'$grok->[0]' flags $grok->[1] - check flags");
}
my $ATOU_MAX = ~0;
# atou tests
my @atous =
(
# [ input, endsv, out uv, out len ]
# Basic cases.
[ "0", "", 0, 1 ],
[ "1", "", 1, 1 ],
[ "2", "", 2, 1 ],
[ "9", "", 9, 1 ],
[ "12", "", 12, 2 ],
[ "123", "", 123, 3 ],
# Trailing whitespace is accepted or rejected, depending on endptr.
[ "0 ", " ", 0, 1 ],
[ "1 ", " ", 1, 1 ],
[ "2 ", " ", 2, 1 ],
[ "12 ", " ", 12, 2 ],
# Trailing garbage is accepted or rejected, depending on endptr.
[ "0x", "x", 0, 1 ],
[ "1x", "x", 1, 1 ],
[ "2x", "x", 2, 1 ],
[ "12x", "x", 12, 2 ],
# Leading whitespace is failure.
[ " 0", undef, 0, 0 ],
[ " 1", undef, 0, 0 ],
[ " 12", undef, 0, 0 ],
# Leading garbage is outright failure.
[ "x0", undef, 0, 0 ],
[ "x1", undef, 0, 0 ],
[ "x12", undef, 0, 0 ],
# We do not parse decimal point.
[ "12.3", ".3", 12, 2 ],
# Leading pluses or minuses are no good.
[ "+12", undef, 0, 0 ],
[ "-12", undef, 0, 0 ],
# Extra leading zeros are no good.
[ "00", undef, $ATOU_MAX, 0 ],
[ "01", undef, $ATOU_MAX, 0 ],
[ "012", undef, $ATOU_MAX, 0 ],
);
# Values near overflow point.
if ($Config{uvsize} == 8) {
push @atous,
(
# 32-bit values no problem for 64-bit.
[ "4294967293", "", 4294967293, 10, ],
[ "4294967294", "", 4294967294, 10, ],
[ "4294967295", "", 4294967295, 10, ],
[ "4294967296", "", 4294967296, 10, ],
[ "4294967297", "", 4294967297, 10, ],
# This is well within 64-bit.
[ "9999999999", "", 9999999999, 10, ],
# Values valid up to 64-bit, failing beyond.
[ "18446744073709551613", "", 18446744073709551613, 20, ],
[ "18446744073709551614", "", 18446744073709551614, 20, ],
[ "18446744073709551615", "", $ATOU_MAX, 20, ],
[ "18446744073709551616", undef, $ATOU_MAX, 0, ],
[ "18446744073709551617", undef, $ATOU_MAX, 0, ],
);
} elsif ($Config{uvsize} == 4) {
push @atous,
(
# Values valid up to 32-bit, failing beyond.
[ "4294967293", "", 4294967293, 10, ],
[ "4294967294", "", 4294967294, 10, ],
[ "4294967295", "", $ATOU_MAX, 10, ],
[ "4294967296", undef, $ATOU_MAX, 0, ],
[ "4294967297", undef, $ATOU_MAX, 0, ],
# Still beyond 32-bit.
[ "4999999999", undef, $ATOU_MAX, 0, ],
[ "5678901234", undef, $ATOU_MAX, 0, ],
[ "6789012345", undef, $ATOU_MAX, 0, ],
[ "7890123456", undef, $ATOU_MAX, 0, ],
[ "8901234567", undef, $ATOU_MAX, 0, ],
[ "9012345678", undef, $ATOU_MAX, 0, ],
[ "9999999999", undef, $ATOU_MAX, 0, ],
[ "10000000000", undef, $ATOU_MAX, 0, ],
[ "12345678901", undef, $ATOU_MAX, 0, ],
# 64-bit values are way beyond.
[ "18446744073709551613", undef, $ATOU_MAX, 0, ],
[ "18446744073709551614", undef, $ATOU_MAX, 0, ],
[ "18446744073709551615", undef, $ATOU_MAX, 0, ],
[ "18446744073709551616", undef, $ATOU_MAX, 0, ],
[ "18446744073709551617", undef, $ATOU_MAX, 0, ],
);
}
# These will fail to fail once 128/256-bit systems arrive.
push @atous,
(
[ "23456789012345678901", undef, $ATOU_MAX, 0 ],
[ "34567890123456789012", undef, $ATOU_MAX, 0 ],
[ "98765432109876543210", undef, $ATOU_MAX, 0 ],
[ "98765432109876543211", undef, $ATOU_MAX, 0 ],
[ "99999999999999999999", undef, $ATOU_MAX, 0 ],
);
for my $grok (@atous) {
my $input = $grok->[0];
my $endsv = $grok->[1];
my $expect_ok = defined $endsv;
my $strict_ok = $expect_ok && $endsv eq '';
my ($ok, $out_uv, $out_len);
# First with endsv.
($ok, $out_uv, $out_len) = grok_atoUV($input, $endsv);
is($expect_ok, $ok, sprintf "'$input' expected %s, got %s",
($expect_ok ? 'success' : 'failure'),
($ok ? 'success' : 'failure'),
);
if ($expect_ok) {
is($expect_ok, $ok, "'$input' expect success");
is($out_uv, $grok->[2],
"'$input' $endsv - number success (got $out_uv cf $grok->[2])");
ok($grok->[3] <= length $input, "'$input' $endsv - length sanity 1");
unless (length $grok->[1]) {
is($out_len, $grok->[3], "'$input' $endsv - length sanity 2");
} # else { ... } ?
if ($out_len) {
is($endsv, substr($input, $out_len),
"'$input' $endsv - length sanity 3");
}
} else {
is($expect_ok, $ok, "'$input' expect failure");
is(0xdeadbeef, $out_uv, "'$input' on failure expect value unchanged");
}
# Then without endsv (undef == NULL).
($ok, $out_uv, $out_len) = grok_atoUV($input, undef);
if ($strict_ok) {
is($strict_ok, $ok, "'$input' expect strict success");
is($out_uv, $grok->[2],
"'$input' $endsv - strict number success (got $out_uv cf $grok->[2])");
} else {
is($strict_ok, $ok, "'$input' expect strict failure");
is(0xdeadbeef, $out_uv, "'$input' on strict failure expect value unchanged");
}
}
done_testing();