This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Scalar-List-Utils to CPAN version 1.54
authorChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Fri, 7 Feb 2020 11:06:59 +0000 (11:06 +0000)
committerChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Fri, 7 Feb 2020 11:06:59 +0000 (11:06 +0000)
  [DELTA]

1.54 -- 2020-02-02 15:47
  [CHANGES]
   * Added List::Util::reductions (RT128237)
   * Added List::Util::sample (RT131535)
   * Recognise $List::Util::RAND as a source of randomness for sampling
     functions (RT131536)

  [BUGFIXES]
   * Document the difference between ref() and reftype() on precompiled
     qr// regexps (RT127963)
   * Various improvements to List::Util::uniqnum() to handle stringified
     Inf and NaN, negative zero
   * Detect platform NV size and number of digits required to calculate
     uniqueness

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 [new file with mode: 0644]
cpan/Scalar-List-Utils/t/sample.t [new file with mode: 0644]
cpan/Scalar-List-Utils/t/shuffle.t
cpan/Scalar-List-Utils/t/uniq.t

index d8d62c6..090810d 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1967,9 +1967,11 @@ 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 a431630..d84c8b1 100755 (executable)
@@ -960,7 +960,7 @@ use File::Glob qw(:case);
     },
 
     'Scalar::Util' => {
-        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.53.tar.gz',
+        'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.54.tar.gz',
         'FILES'        => q[cpan/Scalar-List-Utils],
     },
 
index b0d98b4..466cf66 100644 (file)
@@ -175,6 +175,54 @@ 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
@@ -451,10 +499,14 @@ 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];
@@ -463,8 +515,12 @@ CODE:
     if(cv == Nullcv)
         croak("Not a subroutine reference");
 
-    if(items <= 1)
-        XSRETURN_UNDEF;
+    if(items <= 1) {
+        if(ix)
+            XSRETURN(0);
+        else
+            XSRETURN_UNDEF;
+    }
 
     agv = gv_fetchpv("a", GV_ADD, SVt_PV);
     bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
@@ -472,6 +528,17 @@ 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)) {
@@ -484,6 +551,8 @@ 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)
@@ -502,11 +571,26 @@ CODE:
             call_sv((SV*)cv, G_SCALAR);
 
             SvSetMagicSV(ret, *PL_stack_sp);
+            if(ix)
+                av_push(retvals, newSVsv(ret));
         }
     }
 
-    ST(0) = ret;
-    XSRETURN(1);
+    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);
+    }
 }
 
 void
@@ -1137,31 +1221,17 @@ PROTOTYPE: @
 CODE:
 {
     int index;
-#if (PERL_VERSION < 9)
-    struct op dmy_op;
-    struct op *old_op = PL_op;
+    SV *randsv = get_sv("List::Util::RAND", 0);
+    CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
+        (CV *)SvRV(randsv) : NULL;
 
-    /* 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
+    if(!randcv)
+        MY_initrand(aTHX);
 
     for (index = items ; index > 1 ; ) {
-        int swap = (int)(Drand01() * (double)(index--));
+        int swap = (int)(
+            (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--)
+        );
         SV *tmp = ST(swap);
         ST(swap) = ST(index);
         ST(index) = tmp;
@@ -1170,6 +1240,52 @@ 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(...)
@@ -1201,6 +1317,7 @@ CODE:
 
         for(index = 0 ; index < items ; index++) {
             SV *arg = args[index];
+            NV nv_arg;
 #ifdef HV_FETCH_EMPTY_HE
             HE* he;
 #endif
@@ -1217,12 +1334,35 @@ 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
-                sv_setpvf(keysv, "%.15" NVgf, SvNV(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);
+                }
+            }
 #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 37bd104..51e668e 100644 (file)
@@ -6,12 +6,42 @@ 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       => ($ENV{PERL_CORE} ? q[-DPERL_EXT] : q[-DPERL_EXT -DUSE_PPPORT_H]),
+  DEFINE       => $defines,
   DISTNAME     => q[Scalar-List-Utils],
   VERSION_FROM => 'lib/List/Util.pm',
 
index e1b66c6..bd91801 100644 (file)
@@ -12,16 +12,20 @@ require Exporter;
 
 our @ISA        = qw(Exporter);
 our @EXPORT_OK  = qw(
-  all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
+  all any first min max minstr maxstr none notall product reduce reductions sum sum0
+  sample shuffle uniq uniqnum uniqstr
   head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
 );
-our $VERSION    = "1.53";
+our $VERSION    = "1.54";
 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;
@@ -47,7 +51,7 @@ List::Util - A selection of general-utility list subroutines
 =head1 SYNOPSIS
 
     use List::Util qw(
-      reduce any all none notall first
+      reduce any all none notall first reductions
 
       max maxstr min minstr product sum sum0
 
@@ -69,7 +73,8 @@ By default C<List::Util> does not export any subroutines.
 
 =head1 LIST-REDUCTION FUNCTIONS
 
-The following set of functions all reduce a list down to a single value.
+The following set of functions all apply a given block of code to a list of
+values.
 
 =cut
 
@@ -129,8 +134,28 @@ block that accumulates lengths by writing this instead as:
 
     $total = reduce { $a + length $b } 0, @strings
 
-The remaining list-reduction functions are all specialisations of this generic
-idea.
+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"
 
 =head2 any
 
@@ -489,6 +514,25 @@ 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
@@ -587,6 +631,21 @@ 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 4a7301c..793789f 100644 (file)
@@ -3,7 +3,7 @@ use strict;
 use warnings;
 use List::Util;
 
-our $VERSION = "1.53";       # FIXUP
+our $VERSION = "1.54";       # FIXUP
 $VERSION =~ tr/_//d;         # FIXUP
 
 1;
index bf670c9..ed5d115 100644 (file)
@@ -17,7 +17,7 @@ our @EXPORT_OK = qw(
   dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
   tainted
 );
-our $VERSION    = "1.53";
+our $VERSION    = "1.54";
 $VERSION =~ tr/_//d;
 
 require List::Util; # List::Util loads the XS
@@ -134,6 +134,11 @@ 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 580bd8d..7922eb1 100644 (file)
@@ -15,7 +15,7 @@ our @EXPORT_OK = qw(
   subname set_subname
 );
 
-our $VERSION    = "1.53";
+our $VERSION    = "1.54";
 $VERSION =~ tr/_//d;
 
 require List::Util; # as it has the XS
index 848c34f..857d48f 100644 (file)
@@ -5,7 +5,7 @@ use warnings;
 
 use List::Util qw(reduce min);
 use Test::More;
-plan tests => 30 + ($::PERL_ONLY ? 0 : 2);
+plan tests => 31 + ($::PERL_ONLY ? 0 : 2);
 
 my $v = reduce {};
 
@@ -144,6 +144,11 @@ 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
new file mode 100644 (file)
index 0000000..f26ce2a
--- /dev/null
@@ -0,0 +1,53 @@
+#!./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
new file mode 100644 (file)
index 0000000..27bbb69
--- /dev/null
@@ -0,0 +1,73 @@
+#!./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 dff9637..584f829 100644 (file)
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6;
+use Test::More tests => 7;
 
 use List::Util qw(shuffle);
 
@@ -24,3 +24,13 @@ 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 8e76f21..5f78aeb 100644 (file)
@@ -2,8 +2,8 @@
 
 use strict;
 use warnings;
-
-use Test::More tests => 33;
+use Config; # to determine nvsize
+use Test::More tests => 39;
 use List::Util qw( uniqnum uniqstr uniq );
 
 use Tie::Array;
@@ -87,6 +87,112 @@ 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;
@@ -101,20 +207,43 @@ SKIP: {
     my $maxint = ~0 >> 1;
     my $minint = -(~0 >> 1) - 1;
 
-    my @nums = ($maxuint, $maxuint-1, -1, $Inf, $NaN, $maxint, $minint, 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;
+        }
+    }
 
     is_deeply( [ uniqnum @nums, 1.0 ],
                [ @nums ],
-               'uniqnum preserves uniqness of full integer range' );
+               'uniqnum preserves uniqueness of full integer range' );
 
     my @strs = map "$_", @nums;
 
-    skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 )
-        if $maxuint !~ /\A[0-9]+\z/;
+    if($maxuint !~ /\A[0-9]+\z/) {
+      skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 );
+    }
 
     is_deeply( [ uniqnum @strs, "1.0" ],
                [ @strs ],
-               'uniqnum preserves uniqness of full integer range (stringified)' );
+               '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'
+    );
 }
 
 {
@@ -132,6 +261,10 @@ 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' );