cpan/Scalar-List-Utils/t/uniqnum.t

   1 #!./perl
   2
   3 use strict;
   4 use warnings;
   5 use Config; # to determine nvsize
   6 use Test::More tests => 23;
   7 use List::Util qw( uniqnum );
   8
   9 is_deeply( [ uniqnum qw( 1 1.0 1E0 2 3 ) ],
  10            [ 1, 2, 3 ],
  11            'uniqnum compares numbers' );
  12
  13 is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ],
  14            [ 1, 1.1, 1.2, 1.3 ],
  15            'uniqnum distinguishes floats' );
  16
  17 {
  18     my @nums = map $_+0.1, 1e7..1e7+5;
  19     is_deeply( [ uniqnum @nums ],
  20                [ @nums ],
  21                'uniqnum distinguishes large floats' );
  22
  23     my @strings = map "$_", @nums;
  24     is_deeply( [ uniqnum @strings ],
  25                [ @strings ],
  26                'uniqnum distinguishes large floats (stringified)' );
  27 }
  28
  29 my ($uniq_count1, $uniq_count2, $equiv);
  30
  31 if($Config{nvsize} == 8) {
  32   # NV is either 'double' or 8-byte 'long double'
  33
  34   # The 2 values should be unequal - but just in case perl is buggy:
  35   $equiv = 1 if 1.4142135623730951 == 1.4142135623730954;
  36
  37   $uniq_count1 = uniqnum (1.4142135623730951,
  38                           1.4142135623730954 );
  39
  40   $uniq_count2 = uniqnum('1.4142135623730951',
  41                          '1.4142135623730954' );
  42 }
  43
  44 elsif(length(sqrt(2)) > 25) {
  45   # NV is either IEEE 'long double' or '__float128' or doubledouble
  46
  47   if(1 + (2 ** -1074) != 1) {
  48     # NV is doubledouble
  49
  50     # The 2 values should be unequal - but just in case perl is buggy:
  51     $equiv = 1 if 1 + (2 ** -1074) == 1 + (2 ** - 1073);
  52
  53     $uniq_count1 = uniqnum (1 + (2 ** -1074),
  54                             1 + (2 ** -1073) );
  55     # The 2 values should be unequal - but just in case perl is buggy:
  56     $equiv = 1 if 4.0564819207303340847894502572035e31 == 4.0564819207303340847894502572034e31;
  57
  58     $uniq_count2 = uniqnum('4.0564819207303340847894502572035e31',
  59                            '4.0564819207303340847894502572034e31' );
  60   }
  61
  62   else {
  63     # NV is either IEEE 'long double' or '__float128'
  64
  65     # The 2 values should be unequal - but just in case perl is buggy:
  66     $equiv = 1 if 1005.10228292019306452029161597769015 == 1005.1022829201930645202916159776901;
  67
  68     $uniq_count1 = uniqnum (1005.10228292019306452029161597769015,
  69                             1005.1022829201930645202916159776901 );
  70
  71     $uniq_count2 = uniqnum('1005.10228292019306452029161597769015',
  72                            '1005.1022829201930645202916159776901' );
  73   }
  74 }
  75
  76 else {
  77   # NV is extended precision 'long double'
  78
  79   # The 2 values should be unequal - but just in case perl is buggy:
  80   $equiv = 1 if 10.770329614269008063 == 10.7703296142690080625;
  81
  82   $uniq_count1 = uniqnum (10.770329614269008063,
  83                           10.7703296142690080625 );
  84
  85   $uniq_count2 = uniqnum('10.770329614269008063',
  86                          '10.7703296142690080625' );
  87 }
  88
  89 if($equiv) {
  90   is($uniq_count1, 1, 'uniqnum preserves uniqueness of high precision floats');
  91   is($uniq_count2, 1, 'uniqnum preserves uniqueness of high precision floats (stringified)');
  92 }
  93
  94 else {
  95   is($uniq_count1, 2, 'uniqnum preserves uniqueness of high precision floats');
  96   is($uniq_count2, 2, 'uniqnum preserves uniqueness of high precision floats (stringified)');
  97 }
  98
  99 SKIP: {
 100     skip ('test not relevant for this perl configuration', 1) unless $Config{nvsize} == 8
 101                                                                   && $Config{ivsize} == 8;
 102
 103     my @in = (~0, ~0 - 1, 18446744073709551614.0, 18014398509481985, 1.8014398509481985e16);
 104     my(@correct);
 105
 106     # On perl-5.6.2 (and perhaps other old versions), ~0 - 1 is assigned to an NV.
 107     # This affects the outcome of the following test, so we need to first determine
 108     # whether ~0 - 1 is an NV or a UV:
 109
 110     if("$in[1]" eq "1.84467440737096e+19") {
 111
 112       # It's an NV and $in[2] is a duplicate of $in[1]
 113       @correct = (~0, ~0 - 1, 18014398509481985, 1.8014398509481985e16);
 114     }
 115     else {
 116
 117       # No duplicates in @in
 118       @correct = @in;
 119     }
 120
 121     is_deeply( [ uniqnum @in ],
 122                [ @correct ],
 123                'uniqnum correctly compares UV/IVs that overflow NVs' );
 124 }
 125
 126 my $ls = 31;      # maximum left shift for 32-bit unity
 127
 128 if( $Config{ivsize} == 8 ) {
 129   $ls       = 63; # maximum left shift for 64-bit unity
 130 }
 131
 132 # Populate @in with UV-NV pairs of equivalent values.
 133 # Each of these values is exactly representable as
 134 # either a UV or an NV.
 135
 136 my @in = (1 << $ls, 2 ** $ls,
 137           1 << ($ls - 3), 2 ** ($ls - 3),
 138           5 << ($ls - 3), 5 * (2 ** ($ls - 3)));
 139
 140 my @correct = (1 << $ls, 1 << ($ls - 3), 5 << ($ls -3));
 141
 142 if( $Config{ivsize} == 8 && $Config{nvsize} == 8 ) {
 143
 144      # Add some more UV-NV pairs of equivalent values.
 145      # Each of these values is exactly representable
 146      # as either a UV or an NV.
 147
 148      push @in, ( 9007199254740991,     9.007199254740991e+15,
 149                  9007199254740992,     9.007199254740992e+15,
 150                  9223372036854774784,  9.223372036854774784e+18,
 151                  18446744073709549568, 1.8446744073709549568e+19,
 152                  18446744073709139968, 1.8446744073709139968e+19,
 153                  100000000000262144,   1.00000000000262144e+17,
 154                  100000000001310720,   1.0000000000131072e+17,
 155                  144115188075593728,   1.44115188075593728e+17,
 156                  -9007199254740991,     -9.007199254740991e+15,
 157                  -9007199254740992,     -9.007199254740992e+15,
 158                  -9223372036854774784,  -9.223372036854774784e+18,
 159                  -18446744073709549568, -1.8446744073709549568e+19,
 160                  -18446744073709139968, -1.8446744073709139968e+19,
 161                  -100000000000262144,   -1.00000000000262144e+17,
 162                  -100000000001310720,   -1.0000000000131072e+17,
 163                  -144115188075593728,   -1.44115188075593728e+17 );
 164
 165      push @correct, ( 9007199254740991,
 166                       9007199254740992,
 167                       9223372036854774784,
 168                       18446744073709549568,
 169                       18446744073709139968,
 170                       100000000000262144,
 171                       100000000001310720,
 172                       144115188075593728,
 173                       -9007199254740991,
 174                       -9007199254740992,
 175                       -9223372036854774784,
 176                       -18446744073709549568,
 177                       -18446744073709139968,
 178                       -100000000000262144,
 179                       -100000000001310720,
 180                       -144115188075593728 );
 181 }
 182
 183 # uniqnum should discard each of the NVs as being a
 184 # duplicate of the preceding UV.
 185
 186 is_deeply( [ uniqnum @in],
 187            [ @correct],
 188            'uniqnum correctly compares UV/IVs that don\'t overflow NVs' );
 189
 190 # Hard to know for sure what an Inf is going to be. Lets make one
 191 my $Inf = 0 + 1E1000;
 192 my $NaN;
 193 $Inf **= 1000 while ( $NaN = $Inf - $Inf ) == $NaN;
 194
 195 is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ],
 196            [ 0, 1, 12345, $Inf, -$Inf, $NaN ],
 197            'uniqnum preserves the special values of +-Inf and Nan' );
 198
 199 SKIP: {
 200     my $maxuint = ~0;
 201     my $maxint = ~0 >> 1;
 202     my $minint = -(~0 >> 1) - 1;
 203
 204     my @nums = ($maxuint, $maxuint-1, -1, $maxint, $minint, 1 );
 205
 206     {
 207         use warnings FATAL => 'numeric';
 208         if (eval {
 209             "$Inf" + 0 == $Inf
 210         }) {
 211             push @nums, $Inf;
 212         }
 213         if (eval {
 214             my $nanish = "$NaN" + 0;
 215             $nanish != 0 && !$nanish != $NaN;
 216         }) {
 217             push @nums, $NaN;
 218         }
 219     }
 220
 221     is_deeply( [ uniqnum @nums, 1.0 ],
 222                [ @nums ],
 223                'uniqnum preserves uniqueness of full integer range' );
 224
 225     my @strs = map "$_", @nums;
 226
 227     if($maxuint !~ /\A[0-9]+\z/) {
 228       skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 );
 229     }
 230
 231     is_deeply( [ uniqnum @strs, "1.0" ],
 232                [ @strs ],
 233                'uniqnum preserves uniqueness of full integer range (stringified)' );
 234 }
 235
 236 {
 237     my @nums = (6.82132005170133e-38, 62345678);
 238     is_deeply( [ uniqnum @nums ], [ @nums ],
 239         'uniqnum keeps uniqueness of numbers that stringify to the same byte pattern as a float'
 240     );
 241 }
 242
 243 {
 244     my $warnings = "";
 245     local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
 246
 247     is_deeply( [ uniqnum 0, undef ],
 248                [ 0 ],
 249                'uniqnum considers undef and zero equivalent' );
 250
 251     ok( length $warnings, 'uniqnum on undef yields a warning' );
 252
 253     is_deeply( [ uniqnum undef ],
 254                [ 0 ],
 255                'uniqnum on undef coerces to zero' );
 256 }
 257
 258 is_deeply( [uniqnum 0, -0.0 ],
 259            [0],
 260            'uniqnum handles negative zero');
 261
 262 SKIP: {
 263     skip ('test not relevant for this perl configuration', 4) unless $Config{ivsize} == 8;
 264
 265   # 1e17 is the number beyond which "%.20g" formatting fails on some
 266   # 64-bit int perls.
 267   # The following 2 tests check that the nearest values (both above
 268   # and below that tipping point) are being handled correctly.
 269
 270   # 99999999999999984 is the largest 64-bit integer less than 1e17
 271   # that can be expressed exactly as a double
 272
 273   is_deeply( [ uniqnum (99999999999999984, 99999999999999984.0) ],
 274              [ (99999999999999984) ],
 275              'uniqnum recognizes 99999999999999984 and 99999999999999984.0 as the same' );
 276
 277   is_deeply( [ uniqnum (-99999999999999984, -99999999999999984.0) ],
 278              [ (-99999999999999984) ],
 279              'uniqnum recognizes -99999999999999984 and -99999999999999984.0 as the same' );
 280
 281   # 100000000000000016 is the smallest positive 64-bit integer greater than 1e17
 282   # that can be expressed exactly as a double
 283
 284   is_deeply( [ uniqnum (100000000000000016, 100000000000000016.0) ],
 285              [ (100000000000000016) ],
 286              'uniqnum recognizes 100000000000000016 and 100000000000000016.0 as the same' );
 287
 288   is_deeply( [ uniqnum (-100000000000000016, -100000000000000016.0) ],
 289              [ (-100000000000000016) ],
 290              'uniqnum recognizes -100000000000000016 and -100000000000000016.0 as the same' );
 291 }
 292
 293 # uniqnum not confused by IV'ified floats
 294 SKIP: {
 295     # This fails on 5.6 and isn't fixable without breaking a lot of other tests
 296     skip 'This perl version gets confused by IVNV dualvars', 1 if $] lt '5.008000';
 297     my @nums = ( 2.1, 2.2, 2.3 );
 298     my $dummy = sprintf "%d", $_ for @nums;
 299
 300     # All @nums now have both NOK and IOK but IV=2 in each case
 301     is( scalar( uniqnum @nums ), 3, 'uniqnum not confused by dual IV+NV' );
 302 }
 303
 304 {
 305     package Numify;
 306
 307     use overload '0+' => sub { return $_[0]->{num} };
 308
 309     sub new { bless { num => $_[1] }, $_[0] }
 310
 311     package main;
 312     use Scalar::Util qw( refaddr );
 313
 314     my @nums = map { Numify->new( $_ ) } qw( 2 2 5 );
 315
 316     # is_deeply wants to use eq overloading
 317     my @ret = uniqnum @nums;
 318     ok( scalar @ret == 2 &&
 319         refaddr $ret[0] == refaddr $nums[0] &&
 320         refaddr $ret[1] == refaddr $nums[2],
 321                'uniqnum respects numify overload' );
 322 }
 323
 324 {
 325     "1 1 2" =~ m/(.) (.) (.)/;
 326     is_deeply( [ uniqnum $1, $2, $3 ],
 327                [ 1, 2 ],
 328                'uniqnum handles magic' );
 329 }