This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert "Update Scalar-List-Utils to CPAN version 1.54"
authorYves Orton <demerphq@gmail.com>
Sat, 8 Feb 2020 10:58:32 +0000 (11:58 +0100)
committerYves Orton <demerphq@gmail.com>
Sat, 8 Feb 2020 10:58:32 +0000 (11:58 +0100)
This reverts commit 16933d619ff0a6284a4a90626ab5d39e472c694f.

This breaks Win32 builds as it does not include trunc(),
which is causing havoc with our build process. See issue #17550

13 files changed:
MANIFEST
Porting/Maintainers.pl
cpan/Scalar-List-Utils/ListUtil.xs
cpan/Scalar-List-Utils/Makefile.PL
cpan/Scalar-List-Utils/lib/List/Util.pm
cpan/Scalar-List-Utils/lib/List/Util/XS.pm
cpan/Scalar-List-Utils/lib/Scalar/Util.pm
cpan/Scalar-List-Utils/lib/Sub/Util.pm
cpan/Scalar-List-Utils/t/reduce.t
cpan/Scalar-List-Utils/t/reductions.t [deleted file]
cpan/Scalar-List-Utils/t/sample.t [deleted file]
cpan/Scalar-List-Utils/t/shuffle.t
cpan/Scalar-List-Utils/t/uniq.t

index 090810d..d8d62c6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1967,11 +1967,9 @@ cpan/Scalar-List-Utils/t/product.t               List::Util
 cpan/Scalar-List-Utils/t/prototype.t
 cpan/Scalar-List-Utils/t/readonly.t            Scalar::Util
 cpan/Scalar-List-Utils/t/reduce.t              List::Util
-cpan/Scalar-List-Utils/t/reductions.t
 cpan/Scalar-List-Utils/t/refaddr.t             Scalar::Util
 cpan/Scalar-List-Utils/t/reftype.t             Scalar::Util
 cpan/Scalar-List-Utils/t/rt-96343.t            Scalar::Util
-cpan/Scalar-List-Utils/t/sample.t
 cpan/Scalar-List-Utils/t/scalarutil-proto.t
 cpan/Scalar-List-Utils/t/shuffle.t             List::Util
 cpan/Scalar-List-Utils/t/stack-corruption.t    List::Util
index d84c8b1..a431630 100755 (executable)
@@ -960,7 +960,7 @@ use File::Glob qw(:case);
     },
 
     'Scalar::Util' => {
-        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.54.tar.gz',
+        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.53.tar.gz',
         'FILES'        => q[cpan/Scalar-List-Utils],
     },
 
index 466cf66..b0d98b4 100644 (file)
@@ -175,54 +175,6 @@ static enum slu_accum accum_type(SV *sv) {
 /* Magic for set_subname */
 static MGVTBL subname_vtbl;
 
-static void MY_initrand(pTHX)
-{
-#if (PERL_VERSION < 9)
-    struct op dmy_op;
-    struct op *old_op = PL_op;
-
-    /* We call pp_rand here so that Drand01 get initialized if rand()
-       or srand() has not already been called
-    */
-    memzero((char*)(&dmy_op), sizeof(struct op));
-    /* we let pp_rand() borrow the TARG allocated for this XS sub */
-    dmy_op.op_targ = PL_op->op_targ;
-    PL_op = &dmy_op;
-    (void)*(PL_ppaddr[OP_RAND])(aTHX);
-    PL_op = old_op;
-#else
-    /* Initialize Drand01 if rand() or srand() has
-       not already been called
-    */
-    if(!PL_srand_called) {
-        (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
-        PL_srand_called = TRUE;
-    }
-#endif
-}
-
-static double MY_callrand(pTHX_ CV *randcv)
-{
-    dSP;
-    double ret;
-
-    ENTER;
-    PUSHMARK(SP);
-    PUTBACK;
-
-    call_sv((SV *)randcv, G_SCALAR);
-
-    SPAGAIN;
-
-    ret = POPn;
-    ret -= trunc(ret);      /* bound to < 1 */
-    if(ret < 0) ret += 1.0; /* bound to 0 <= ret < 1 */
-
-    LEAVE;
-
-    return ret;
-}
-
 MODULE=List::Util       PACKAGE=List::Util
 
 void
@@ -499,14 +451,10 @@ void
 reduce(block,...)
     SV *block
 PROTOTYPE: &@
-ALIAS:
-    reduce     = 0
-    reductions = 1
 CODE:
 {
     SV *ret = sv_newmortal();
     int index;
-    AV *retvals;
     GV *agv,*bgv,*gv;
     HV *stash;
     SV **args = &PL_stack_base[ax];
@@ -515,12 +463,8 @@ CODE:
     if(cv == Nullcv)
         croak("Not a subroutine reference");
 
-    if(items <= 1) {
-        if(ix)
-            XSRETURN(0);
-        else
-            XSRETURN_UNDEF;
-    }
+    if(items <= 1)
+        XSRETURN_UNDEF;
 
     agv = gv_fetchpv("a", GV_ADD, SVt_PV);
     bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
@@ -528,17 +472,6 @@ CODE:
     SAVESPTR(GvSV(bgv));
     GvSV(agv) = ret;
     SvSetMagicSV(ret, args[1]);
-
-    if(ix) {
-        /* Precreate an AV for return values; -1 for cv, -1 for top index */
-        retvals = newAV();
-        av_extend(retvals, items-1-1);
-
-        /* so if throw an exception they can be reclaimed */
-        SAVEFREESV(retvals);
-
-        av_push(retvals, newSVsv(ret));
-    }
 #ifdef dMULTICALL
     assert(cv);
     if(!CvISXSUB(cv)) {
@@ -551,8 +484,6 @@ CODE:
             GvSV(bgv) = args[index];
             MULTICALL;
             SvSetMagicSV(ret, *PL_stack_sp);
-            if(ix)
-                av_push(retvals, newSVsv(ret));
         }
 #  ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
         if(CvDEPTH(multicall_cv) > 1)
@@ -571,26 +502,11 @@ CODE:
             call_sv((SV*)cv, G_SCALAR);
 
             SvSetMagicSV(ret, *PL_stack_sp);
-            if(ix)
-                av_push(retvals, newSVsv(ret));
         }
     }
 
-    if(ix) {
-        int i;
-        SV **svs = AvARRAY(retvals);
-        /* steal the SVs from retvals */
-        for(i = 0; i < items-1; i++) {
-            ST(i) = sv_2mortal(svs[i]);
-            svs[i] = NULL;
-        }
-
-        XSRETURN(items-1);
-    }
-    else {
-        ST(0) = ret;
-        XSRETURN(1);
-    }
+    ST(0) = ret;
+    XSRETURN(1);
 }
 
 void
@@ -1221,17 +1137,31 @@ PROTOTYPE: @
 CODE:
 {
     int index;
-    SV *randsv = get_sv("List::Util::RAND", 0);
-    CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
-        (CV *)SvRV(randsv) : NULL;
+#if (PERL_VERSION < 9)
+    struct op dmy_op;
+    struct op *old_op = PL_op;
 
-    if(!randcv)
-        MY_initrand(aTHX);
+    /* We call pp_rand here so that Drand01 get initialized if rand()
+       or srand() has not already been called
+    */
+    memzero((char*)(&dmy_op), sizeof(struct op));
+    /* we let pp_rand() borrow the TARG allocated for this XS sub */
+    dmy_op.op_targ = PL_op->op_targ;
+    PL_op = &dmy_op;
+    (void)*(PL_ppaddr[OP_RAND])(aTHX);
+    PL_op = old_op;
+#else
+    /* Initialize Drand01 if rand() or srand() has
+       not already been called
+    */
+    if(!PL_srand_called) {
+        (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
+        PL_srand_called = TRUE;
+    }
+#endif
 
     for (index = items ; index > 1 ; ) {
-        int swap = (int)(
-            (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--)
-        );
+        int swap = (int)(Drand01() * (double)(index--));
         SV *tmp = ST(swap);
         ST(swap) = ST(index);
         ST(index) = tmp;
@@ -1240,52 +1170,6 @@ CODE:
     XSRETURN(items);
 }
 
-void
-sample(...)
-PROTOTYPE: $@
-CODE:
-{
-    UV count = items ? SvUV(ST(0)) : 0;
-    int reti = 0;
-    SV *randsv = get_sv("List::Util::RAND", 0);
-    CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
-        (CV *)SvRV(randsv) : NULL;
-
-    if(!count)
-        XSRETURN(0);
-
-    /* Now we've extracted count from ST(0) the rest of this logic will be a
-     * lot neater if we move the topmost item into ST(0) so we can just work
-     * within 0..items-1 */
-    ST(0) = POPs;
-    items--;
-
-    if(count > items)
-        count = items;
-
-    if(!randcv)
-        MY_initrand(aTHX);
-
-    /* Partition the stack into ST(0)..ST(reti-1) containing the sampled results
-     * and ST(reti)..ST(items-1) containing the remaining pending candidates
-     */
-    while(reti < count) {
-        int index = (int)(
-            (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(items - reti)
-        );
-
-        SV *selected = ST(reti + index);
-        /* preserve the element we're about to stomp on by putting it back into
-         * the pending partition */
-        ST(reti + index) = ST(reti);
-
-        ST(reti) = selected;
-        reti++;
-    }
-
-    XSRETURN(reti);
-}
-
 
 void
 uniq(...)
@@ -1317,7 +1201,6 @@ CODE:
 
         for(index = 0 ; index < items ; index++) {
             SV *arg = args[index];
-            NV nv_arg;
 #ifdef HV_FETCH_EMPTY_HE
             HE* he;
 #endif
@@ -1334,35 +1217,12 @@ CODE:
 #endif
             }
 
-            if(!SvOK(arg) || SvUOK(arg)) {
+            if(!SvOK(arg) || SvUOK(arg))
                 sv_setpvf(keysv, "%" UVuf, SvUV(arg));
-            }
-            else if(SvIOK(arg)) {
+            else if(SvIOK(arg))
                 sv_setpvf(keysv, "%" IVdf, SvIV(arg));
-            }
-            else {
-                nv_arg = SvNV(arg);
-                /* use 0 for both 0 and -0.0 */
-                if(nv_arg == 0) {
-                    sv_setpvs(keysv, "0");
-                }
-                /* for NaN, use the platform's normal stringification */
-                else if (nv_arg != nv_arg) {
-                    sv_setpvf(keysv, "%" NVgf, nv_arg);
-                }
-                /* for numbers outside of the IV or UV range, we don't need to
-                 * use a comparable format, so just use the raw bytes, adding
-                 * 'f' to ensure not matching a stringified number */
-                else if (nv_arg < (NV)IV_MIN || nv_arg > (NV)UV_MAX) {
-                    sv_setpvn(keysv, (char *) &nv_arg, sizeof(NV));
-                    sv_catpvn(keysv, "f", 1);
-                }
-                /* smaller floats get formatted using %g and could be equal to
-                 * a UV or IV */
-                else {
-                    sv_setpvf(keysv, "%0.*" NVgf, NV_MAX_PRECISION, nv_arg);
-                }
-            }
+            else
+                sv_setpvf(keysv, "%.15" NVgf, SvNV(arg));
 #ifdef HV_FETCH_EMPTY_HE
             he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
             if (HeVAL(he))
index 51e668e..37bd104 100644 (file)
@@ -6,42 +6,12 @@ use Config;
 use File::Spec;
 use ExtUtils::MakeMaker;
 my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV;
-my $defines = $ENV{PERL_CORE} ? q[-DPERL_EXT] : q[-DPERL_EXT -DUSE_PPPORT_H];
-
-my $nv_digits;
-
-my $ivsize = $Config{ivsize} * 8;
-my $uv_digits = 1 + int(log(2) / log(10) * $ivsize);
-
-my $nvsize = $Config{nvsize} * 8;
-# we want NV and UV numbers in the same range to format the same, so make sure
-# NVs are given at least as many digits as UVs.  If IV/UVs have equal or
-# greater bits, there's no reason to check NV size since it won't be able to
-# have as much mantissa.
-if ($ivsize >= $nvsize) {
-  $nv_digits = $uv_digits;
-}
-else {
-  # maximum possible digits that could fit in something NV size
-  my $max_digits = 1 + int(log(2) / log(10) * $nvsize);
-
-  my $float = sprintf '%0.'.$max_digits.'g', 1/9;
-  my ($accurate_digits) = $float =~ /(1+)/;
-  # additional digit provides 'partial' accuracy
-  $nv_digits = 1 + length $accurate_digits;
-
-  if ($nv_digits < $uv_digits) {
-    $nv_digits = $uv_digits;
-  }
-}
-
-$defines .= " -DNV_MAX_PRECISION=$nv_digits";
 
 WriteMakefile(
   NAME         => q[List::Util],
   ABSTRACT     => q[Common Scalar and List utility subroutines],
   AUTHOR       => q[Graham Barr <gbarr@cpan.org>],
-  DEFINE       => $defines,
+  DEFINE       => ($ENV{PERL_CORE} ? q[-DPERL_EXT] : q[-DPERL_EXT -DUSE_PPPORT_H]),
   DISTNAME     => q[Scalar-List-Utils],
   VERSION_FROM => 'lib/List/Util.pm',
 
index bd91801..e1b66c6 100644 (file)
@@ -12,20 +12,16 @@ require Exporter;
 
 our @ISA        = qw(Exporter);
 our @EXPORT_OK  = qw(
-  all any first min max minstr maxstr none notall product reduce reductions sum sum0
-  sample shuffle uniq uniqnum uniqstr
+  all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
   head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
 );
-our $VERSION    = "1.54";
+our $VERSION    = "1.53";
 our $XS_VERSION = $VERSION;
 $VERSION =~ tr/_//d;
 
 require XSLoader;
 XSLoader::load('List::Util', $XS_VERSION);
 
-# Used by shuffle()
-our $RAND;
-
 sub import
 {
   my $pkg = caller;
@@ -51,7 +47,7 @@ List::Util - A selection of general-utility list subroutines
 =head1 SYNOPSIS
 
     use List::Util qw(
-      reduce any all none notall first reductions
+      reduce any all none notall first
 
       max maxstr min minstr product sum sum0
 
@@ -73,8 +69,7 @@ By default C<List::Util> does not export any subroutines.
 
 =head1 LIST-REDUCTION FUNCTIONS
 
-The following set of functions all apply a given block of code to a list of
-values.
+The following set of functions all reduce a list down to a single value.
 
 =cut
 
@@ -134,28 +129,8 @@ block that accumulates lengths by writing this instead as:
 
     $total = reduce { $a + length $b } 0, @strings
 
-The other scalar-returning list reduction functions are all specialisations of
-this generic idea.
-
-=head2 reductions
-
-    @results = reductions { BLOCK } @list
-
-I<Since version 1.54.>
-
-Similar to C<reduce> except that it also returns the intermediate values along
-with the final result. As before, C<$a> is set to the first element of the
-given list, and the C<BLOCK> is then called once for remaining item in the
-list set into C<$b>, with the result being captured for return as well as
-becoming the new value for C<$a>.
-
-The returned list will begin with the initial value for C<$a>, followed by
-each return value from the block in order. The final value of the result will
-be identical to what the C<reduce> function would have returned given the same
-block and list.
-
-    reduce     { "$a-$b" }  "a".."d"    # "a-b-c-d"
-    reductions { "$a-$b" }  "a".."d"    # "a", "a-b", "a-b-c", "a-b-c-d"
+The remaining list-reduction functions are all specialisations of this generic
+idea.
 
 =head2 any
 
@@ -514,25 +489,6 @@ Returns the values of the input in a random order
 
     @cards = shuffle 0..51      # 0..51 in a random order
 
-This function is affected by the C<$RAND> variable.
-
-=cut
-
-=head2 sample
-
-    my @items = sample $count, @values
-
-I<Since version 1.54.>
-
-Randomly select the given number of elements from the input list. Any given
-position in the input list will be selected at most once.
-
-If there are fewer than C<$count> items in the list then the function will
-return once all of them have been randomly selected; effectively the function
-behaves similarly to L</shuffle>.
-
-This function is affected by the C<$RAND> variable.
-
 =head2 uniq
 
     my @subset = uniq @values
@@ -631,21 +587,6 @@ all but the first C<$size> elements from C<@list>.
     @result = tail -2, qw( foo bar baz );
     # baz
 
-=head1 CONFIGURATION VARIABLES
-
-=head2 $RAND
-
-    local $List::Util::RAND = sub { ... };
-
-I<Since version 1.54.>
-
-This package variable is used by code which needs to generate random numbers
-(such as the L</shuffle> and L</sample> functions). If set to a CODE reference
-it provides an alternative to perl's builtin C<rand()> function. When a new
-random number is needed this function will be invoked with no arguments and is
-expected to return a floating-point value, of which only the fractional part
-will be used.
-
 =head1 KNOWN BUGS
 
 =head2 RT #95409
index 793789f..4a7301c 100644 (file)
@@ -3,7 +3,7 @@ use strict;
 use warnings;
 use List::Util;
 
-our $VERSION = "1.54";       # FIXUP
+our $VERSION = "1.53";       # FIXUP
 $VERSION =~ tr/_//d;         # FIXUP
 
 1;
index ed5d115..bf670c9 100644 (file)
@@ -17,7 +17,7 @@ our @EXPORT_OK = qw(
   dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
   tainted
 );
-our $VERSION    = "1.54";
+our $VERSION    = "1.53";
 $VERSION =~ tr/_//d;
 
 require List::Util; # List::Util loads the XS
@@ -134,11 +134,6 @@ is returned.
     $obj  = bless {}, "Foo";
     $type = reftype $obj;               # HASH
 
-Note that for internal reasons, all precompiled regexps (C<qr/.../>) are
-blessed references; thus C<ref()> returns the package name string C<"Regexp">
-on these but C<reftype()> will return the underlying C structure type of
-C<"REGEXP"> in all capitals.
-
 =head2 weaken
 
     weaken( $ref );
index 7922eb1..580bd8d 100644 (file)
@@ -15,7 +15,7 @@ our @EXPORT_OK = qw(
   subname set_subname
 );
 
-our $VERSION    = "1.54";
+our $VERSION    = "1.53";
 $VERSION =~ tr/_//d;
 
 require List::Util; # as it has the XS
index 857d48f..848c34f 100644 (file)
@@ -5,7 +5,7 @@ use warnings;
 
 use List::Util qw(reduce min);
 use Test::More;
-plan tests => 31 + ($::PERL_ONLY ? 0 : 2);
+plan tests => 30 + ($::PERL_ONLY ? 0 : 2);
 
 my $v = reduce {};
 
@@ -144,11 +144,6 @@ if (!$::PERL_ONLY) { SKIP: {
 
 } }
 
-{
-  my @ret = reduce { $a + $b } 1 .. 5;
-  is_deeply( \@ret, [ 15 ], 'reduce in list context yields only final answer' );
-}
-
 # XSUB callback
 use constant XSUBC => 42;
 
diff --git a/cpan/Scalar-List-Utils/t/reductions.t b/cpan/Scalar-List-Utils/t/reductions.t
deleted file mode 100644 (file)
index f26ce2a..0000000
+++ /dev/null
@@ -1,53 +0,0 @@
-#!./perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use List::Util qw( reductions );
-
-is_deeply( [ reductions { } ], [],
-  'emmpty list'
-);
-
-is_deeply(
-  [ reductions { $a + $b } 1 .. 5 ],
-  [ 1, 3, 6, 10, 15 ],
-  'sum 1..5'
-);
-
-# We don't guarantee what this will return but it definitely shouldn't crash
-{
-  my $ret = reductions { $a + $b } 1 .. 3;
-  pass( 'reductions in scalar context does not crash' );
-}
-
-my $destroyed_count;
-sub Guardian::DESTROY { $destroyed_count++ }
-
-{
-  undef $destroyed_count;
-
-  my @ret = reductions { $b } map { bless [], "Guardian" } 1 .. 5;
-
-  ok( !$destroyed_count, 'nothing destroyed yet' );
-
-  @ret = ();
-
-  is( $destroyed_count, 5, 'all the items were destroyed' );
-}
-
-{
-  undef $destroyed_count;
-
-  ok( !defined eval {
-      reductions { die "stop" if $b == 4; bless [], "Guardian" } 1 .. 4;
-      1
-    }, 'die in BLOCK is propagated'
-  );
-
-  is( $destroyed_count, 2, 'intermediate temporaries are destroyed after exception' );
-}
-
-done_testing;
diff --git a/cpan/Scalar-List-Utils/t/sample.t b/cpan/Scalar-List-Utils/t/sample.t
deleted file mode 100644 (file)
index 27bbb69..0000000
+++ /dev/null
@@ -1,73 +0,0 @@
-#!./perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use List::Util qw(sample);
-
-{
-  my @items = sample 3, 1 .. 10;
-  is( scalar @items, 3, 'returns correct count when plentiful' );
-
-  @items = sample 10, 1 .. 10;
-  is( scalar @items, 10, 'returns correct count when exact' );
-
-  @items = sample 20, 1 .. 10;
-  is( scalar @items, 10, 'returns correct count when short' );
-}
-
-{
-  my @items = sample 5, 1 .. 5;
-  is_deeply( [ sort { $a <=> $b } @items ], [ 1 .. 5 ],
-    'returns a permutation of the input list when exact' );
-}
-
-{
-  # These two seeds happen to give different results for me, but there is the
-  # smallest 1-in-2**48 chance that they happen to agree on some platform. If
-  # so then pick a different seed value.
-
-  srand 1234;
-  my $x = join "", sample 3, 'a'..'z';
-
-  srand 5678;
-  my $y = join "", sample 3, 'a'..'z';
-
-  isnt( $x, $y, 'returns different result on different random seed' );
-
-  srand;
-}
-
-{
-  my @nums = ( 1..5 );
-  sample 5, @nums;
-
-  is_deeply( \@nums, [ 1..5 ],
-    'sample does not mutate passed array'
-  );
-}
-
-{
-  my $destroyed_count;
-  sub Guardian::DESTROY { $destroyed_count++ }
-
-  my @ret = sample 3, map { bless [], "Guardian" } 1 .. 10;
-
-  is( $destroyed_count, 7, 'the 7 unselected items were destroyed' );
-
-  @ret = ();
-
-  is( $destroyed_count, 10, 'all the items were destroyed' );
-}
-
-{
-  local $List::Util::RAND = sub { 4/10 };
-
-  is( join( "", sample 5, 'A'..'Z' ), 'JKALC',
-    'rigged rand() yields predictable output'
-  );
-}
-
-done_testing;
index 584f829..dff9637 100644 (file)
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 7;
+use Test::More tests => 6;
 
 use List::Util qw(shuffle);
 
@@ -24,13 +24,3 @@ isnt( "@r",  "@in",  'result different to args');
 
 my @s = sort { $a <=> $b } @r;
 is( "@in",     "@s",   'values');
-
-{
-  local $List::Util::RAND = sub { 4/10 }; # chosen by a fair die
-
-  @r = shuffle(1..10);
-  # This random function happens to always generate the same result
-  is_deeply( \@r, [ 10, 1, 8, 2, 6, 7, 3, 9, 4, 5 ],
-    'rigged rand() yields predictable output'
-  );
-}
index 5f78aeb..8e76f21 100644 (file)
@@ -2,8 +2,8 @@
 
 use strict;
 use warnings;
-use Config; # to determine nvsize
-use Test::More tests => 39;
+
+use Test::More tests => 33;
 use List::Util qw( uniqnum uniqstr uniq );
 
 use Tie::Array;
@@ -87,112 +87,6 @@ is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ],
                'uniqnum distinguishes large floats (stringified)' );
 }
 
-my ($uniq_count1, $uniq_count2, $equiv);
-
-if($Config{nvsize} == 8) {
-  # NV is either 'double' or 8-byte 'long double'
-
-  # The 2 values should be unequal - but just in case perl is buggy:
-  $equiv = 1 if 1.4142135623730951 == 1.4142135623730954;
-
-  $uniq_count1 = uniqnum (1.4142135623730951,
-                          1.4142135623730954 );
-
-  $uniq_count2 = uniqnum('1.4142135623730951',
-                         '1.4142135623730954' );
-}
-
-elsif(length(sqrt(2)) > 25) {
-  # NV is either IEEE 'long double' or '__float128' or doubledouble
-
-  if(1 + (2 ** -1074) != 1) {
-    # NV is doubledouble
-
-    # The 2 values should be unequal - but just in case perl is buggy:
-    $equiv = 1 if 1 + (2 ** -1074) == 1 + (2 ** - 1073);
-
-    $uniq_count1 = uniqnum (1 + (2 ** -1074),
-                            1 + (2 ** -1073) );
-    # The 2 values should be unequal - but just in case perl is buggy:
-    $equiv = 1 if 4.0564819207303340847894502572035e31 == 4.0564819207303340847894502572034e31;
-
-    $uniq_count2 = uniqnum('4.0564819207303340847894502572035e31',
-                           '4.0564819207303340847894502572034e31' );
-  }
-
-  else {
-    # NV is either IEEE 'long double' or '__float128'
-
-    # The 2 values should be unequal - but just in case perl is buggy:
-    $equiv = 1 if 1.7320508075688772935274463415058722 == 1.73205080756887729352744634150587224;
-
-    $uniq_count1 = uniqnum (1.7320508075688772935274463415058722,
-                            1.73205080756887729352744634150587224 );
-
-    $uniq_count2 = uniqnum('1.7320508075688772935274463415058722',
-                           '1.73205080756887729352744634150587224' );
-  }
-}
-
-else {
-  # NV is extended precision 'long double'
-
-  # The 2 values should be unequal - but just in case perl is buggy:
-  $equiv = 1 if 2.2360679774997896963 == 2.23606797749978969634;
-
-  $uniq_count1 = uniqnum (2.2360679774997896963,
-                          2.23606797749978969634 );
-
-  $uniq_count2 = uniqnum('2.2360679774997896963',
-                         '2.23606797749978969634' );
-}
-
-if($equiv) {
-  is($uniq_count1, 1, 'uniqnum preserves uniqueness of high precision floats');
-  is($uniq_count2, 1, 'uniqnum preserves uniqueness of high precision floats (stringified)');
-}
-
-else {
-  is($uniq_count1, 2, 'uniqnum preserves uniqueness of high precision floats');
-  is($uniq_count2, 2, 'uniqnum preserves uniqueness of high precision floats (stringified)');
-}
-
-SKIP: {
-    skip ('test not relevant for this perl configuration', 1) unless $Config{nvsize} == 8
-                                                                  && $Config{ivsize} == 8;
-
-    my @in = (~0, ~0 - 1, 18446744073709551614.0, 18014398509481985, 1.8014398509481985e16);
-    my(@correct);
-
-    # On perl-5.6.2 (and perhaps other old versions), ~0 - 1 is assigned to an NV.
-    # This affects the outcome of the following test, so we need to first determine
-    # whether ~0 - 1 is an NV or a UV:
-
-    if("$in[1]" eq "1.84467440737096e+19") {
-
-      # It's an NV and $in[2] is a duplicate of $in[1]
-      @correct = (~0, ~0 - 1, 18014398509481985, 1.8014398509481985e16);
-    }
-    else {
-
-      # No duplicates in @in
-      @correct = @in;
-    }
-
-    is_deeply( [ uniqnum @in ],
-               [ @correct ],
-               'uniqnum correctly compares UV/IVs that overflow NVs' );
-}
-
-my $ls = 31;
-if($Config{ivsize} == 8) { $ls = 63 }
-
-is_deeply( [ uniqnum ( 1 << $ls, 2 ** $ls,
-                       1 << ($ls - 3), 2 ** ($ls - 3),
-                       5 << ($ls - 3), 5 * (2 ** ($ls - 3))) ],
-           [ 1 << $ls, 1 << ($ls - 3), 5 << ($ls -3) ],
-           'uniqnum correctly compares UV/IVs that don\'t overflow NVs' );
-
 # Hard to know for sure what an Inf is going to be. Lets make one
 my $Inf = 0 + 1E1000;
 my $NaN;
@@ -207,43 +101,20 @@ SKIP: {
     my $maxint = ~0 >> 1;
     my $minint = -(~0 >> 1) - 1;
 
-    my @nums = ($maxuint, $maxuint-1, -1, $maxint, $minint, 1 );
-
-    {
-        use warnings FATAL => 'numeric';
-        if (eval {
-            "$Inf" + 0 == $Inf
-        }) {
-            push @nums, $Inf;
-        }
-        if (eval {
-            my $nanish = "$NaN" + 0;
-            $nanish != 0 && !$nanish != $NaN;
-        }) {
-            push @nums, $NaN;
-        }
-    }
+    my @nums = ($maxuint, $maxuint-1, -1, $Inf, $NaN, $maxint, $minint, 1 );
 
     is_deeply( [ uniqnum @nums, 1.0 ],
                [ @nums ],
-               'uniqnum preserves uniqueness of full integer range' );
+               'uniqnum preserves uniqness of full integer range' );
 
     my @strs = map "$_", @nums;
 
-    if($maxuint !~ /\A[0-9]+\z/) {
-      skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 );
-    }
+    skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 )
+        if $maxuint !~ /\A[0-9]+\z/;
 
     is_deeply( [ uniqnum @strs, "1.0" ],
                [ @strs ],
-               'uniqnum preserves uniqueness of full integer range (stringified)' );
-}
-
-{
-    my @nums = (6.82132005170133e-38, 62345678);
-    is_deeply( [ uniqnum @nums ], [ @nums ],
-        'uniqnum keeps uniqueness of numbers that stringify to the same byte pattern as a float'
-    );
+               'uniqnum preserves uniqness of full integer range (stringified)' );
 }
 
 {
@@ -261,10 +132,6 @@ SKIP: {
                'uniqnum on undef coerces to zero' );
 }
 
-is_deeply( [uniqnum 0, -0.0 ],
-           [0],
-           'uniqnum handles negative zero');
-
 is_deeply( [ uniq () ],
            [],
            'uniq of empty list' );