This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Scalar-List-Utils to 1.55
authorSawyer X <xsawyerx@cpan.org>
Mon, 1 Jun 2020 07:05:08 +0000 (10:05 +0300)
committerSawyer X <xsawyerx@cpan.org>
Tue, 2 Jun 2020 05:37:38 +0000 (08:37 +0300)
28 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/blessed.t
cpan/Scalar-List-Utils/t/dualvar.t
cpan/Scalar-List-Utils/t/exotic_names.t
cpan/Scalar-List-Utils/t/first.t
cpan/Scalar-List-Utils/t/isvstring.t
cpan/Scalar-List-Utils/t/lln.t
cpan/Scalar-List-Utils/t/readonly.t
cpan/Scalar-List-Utils/t/reduce.t
cpan/Scalar-List-Utils/t/reductions.t [new file with mode: 0644]
cpan/Scalar-List-Utils/t/refaddr.t
cpan/Scalar-List-Utils/t/reftype.t
cpan/Scalar-List-Utils/t/sample.t [new file with mode: 0644]
cpan/Scalar-List-Utils/t/scalarutil-proto.t
cpan/Scalar-List-Utils/t/shuffle.t
cpan/Scalar-List-Utils/t/sum.t
cpan/Scalar-List-Utils/t/tainted.t
cpan/Scalar-List-Utils/t/uniq.t
cpan/Scalar-List-Utils/t/uniqnum.t [new file with mode: 0644]
cpan/Scalar-List-Utils/t/weak.t
pod/perldelta.pod

index 7002ee4..946b8f1 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
@@ -1978,6 +1980,7 @@ cpan/Scalar-List-Utils/t/sum.t                    List::Util
 cpan/Scalar-List-Utils/t/sum0.t
 cpan/Scalar-List-Utils/t/tainted.t             Scalar::Util
 cpan/Scalar-List-Utils/t/uniq.t                        Scalar::Util
+cpan/Scalar-List-Utils/t/uniqnum.t
 cpan/Scalar-List-Utils/t/weak.t                        Scalar::Util
 cpan/Socket/Makefile.PL                        Socket extension makefile writer
 cpan/Socket/Socket.pm                  Socket extension Perl module
index 41c2e2c..b5ffbaf 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.55.tar.gz',
         'FILES'        => q[cpan/Scalar-List-Utils],
     },
 
index b0d98b4..5bccc88 100644 (file)
@@ -2,6 +2,7 @@
  * This program is free software; you can redistribute it and/or
  * modify it under the same terms as Perl itself.
  */
+
 #define PERL_NO_GET_CONTEXT /* we want efficiency */
 #include <EXTERN.h>
 #include <perl.h>
 #  include "ppport.h"
 #endif
 
+/* For uniqnum, define ACTUAL_NVSIZE to be the number *
+ * of bytes that are actually used to store the NV    */
+
+#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 64
+#  define ACTUAL_NVSIZE 10
+#else
+#  define ACTUAL_NVSIZE NVSIZE
+#endif
+
+/* Detect "DoubleDouble" nvtype */
+
+#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 106
+#  define NV_IS_DOUBLEDOUBLE
+#endif  
+
 #ifndef PERL_VERSION_DECIMAL
 #  define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
 #endif
 #ifndef PERL_DECIMAL_VERSION
 #  define PERL_DECIMAL_VERSION \
-         PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
+        PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
 #endif
 #ifndef PERL_VERSION_GE
 #  define PERL_VERSION_GE(r,v,s) \
-         (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
+        (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
 #endif
 #ifndef PERL_VERSION_LE
 #  define PERL_VERSION_LE(r,v,s) \
-         (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
+        (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
 #endif
 
 #if PERL_VERSION_GE(5,6,0)
 #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l)
 #endif
 
+#if !PERL_VERSION_GE(5,8,0)
+static NV Perl_ceil(NV nv) {
+    return -Perl_floor(-nv);
+}
+#endif
+
 /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
    was not exported. Therefore platforms like win32, VMS etc have problems
    so we redefine it here -- GMB
@@ -175,6 +197,53 @@ 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, dummy;
+
+    ENTER;
+    PUSHMARK(SP);
+    PUTBACK;
+
+    call_sv((SV *)randcv, G_SCALAR);
+
+    SPAGAIN;
+
+    ret = modf(POPn, &dummy);      /* 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 +520,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 +536,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 +549,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 +572,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 +592,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 +1242,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,12 +1261,58 @@ CODE:
     XSRETURN(items);
 }
 
+void
+sample(...)
+PROTOTYPE: $@
+CODE:
+{
+    IV count = items ? SvUV(ST(0)) : 0;
+    IV 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(...)
 PROTOTYPE: @
 ALIAS:
-    uniqnum = 0
+    uniqint = 0
     uniqstr = 1
     uniq    = 2
 CODE:
@@ -1184,6 +1321,7 @@ CODE:
     int index;
     SV **args = &PL_stack_base[ax];
     HV *seen;
+    int seen_undef = 0;
 
     if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
         /* Optimise for the case of the empty list or a defined nonmagic
@@ -1194,96 +1332,230 @@ CODE:
 
     sv_2mortal((SV *)(seen = newHV()));
 
-    if(ix == 0) {
-        /* uniqnum */
-        /* A temporary buffer for number stringification */
-        SV *keysv = sv_newmortal();
-
-        for(index = 0 ; index < items ; index++) {
-            SV *arg = args[index];
+    for(index = 0 ; index < items ; index++) {
+        SV *arg = args[index];
 #ifdef HV_FETCH_EMPTY_HE
-            HE* he;
+        HE *he;
 #endif
 
-            if(SvGAMAGIC(arg))
-                /* clone the value so we don't invoke magic again */
-                arg = sv_mortalcopy(arg);
+        if(SvGAMAGIC(arg))
+            /* clone the value so we don't invoke magic again */
+            arg = sv_mortalcopy(arg);
 
-            if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) {
+        if(ix == 2 && !SvOK(arg)) {
+            /* special handling of undef for uniq() */
+            if(seen_undef)
+                continue;
+
+            seen_undef++;
+
+            if(GIMME_V == G_ARRAY)
+                ST(retcount) = arg;
+            retcount++;
+            continue;
+        }
+        if(ix == 0) {
+            /* uniqint */
+            /* coerce to integer */
 #if PERL_VERSION >= 8
-                SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */
-#else
-                SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */
+            /* int_amg only appeared in perl 5.8.0 */
+            if(SvAMAGIC(arg) && (arg = AMG_CALLun(arg, int)))
+                ; /* nothing to do */
+            else
 #endif
+            if(!SvOK(arg) || SvNOK(arg) || SvPOK(arg))
+            {
+                /* Convert undef, NVs and PVs into a well-behaved int */
+                NV nv = SvNV(arg);
+
+                if(nv > (NV)UV_MAX)
+                    /* Too positive for UV - use NV */
+                    arg = newSVnv(Perl_floor(nv));
+                else if(nv < (NV)IV_MIN)
+                    /* Too negative for IV - use NV */
+                    arg = newSVnv(Perl_ceil(nv));
+                else if(nv > 0 && (UV)nv > (UV)IV_MAX)
+                    /* Too positive for IV - use UV */
+                    arg = newSVuv(nv);
+                else
+                    /* Must now fit into IV */
+                    arg = newSViv(nv);
+
+                sv_2mortal(arg);
             }
-
-            if(!SvOK(arg) || SvUOK(arg))
-                sv_setpvf(keysv, "%" UVuf, SvUV(arg));
-            else if(SvIOK(arg))
-                sv_setpvf(keysv, "%" IVdf, SvIV(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))
-                continue;
+        he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
+        if (HeVAL(he))
+            continue;
 
-            HeVAL(he) = &PL_sv_undef;
+        HeVAL(he) = &PL_sv_undef;
 #else
-            if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
-                continue;
+        if (hv_exists_ent(seen, arg, 0))
+            continue;
 
-            hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
+        hv_store_ent(seen, arg, &PL_sv_yes, 0);
 #endif
 
-            if(GIMME_V == G_ARRAY)
-                ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
-            retcount++;
-        }
+        if(GIMME_V == G_ARRAY)
+            ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
+        retcount++;
     }
-    else {
-        /* uniqstr or uniq */
-        int seen_undef = 0;
 
-        for(index = 0 ; index < items ; index++) {
-            SV *arg = args[index];
+  finish:
+    if(GIMME_V == G_ARRAY)
+        XSRETURN(retcount);
+    else
+        ST(0) = sv_2mortal(newSViv(retcount));
+}
+
+void
+uniqnum(...)
+PROTOTYPE: @
+CODE:
+{
+    int retcount = 0;
+    int index;
+    SV **args = &PL_stack_base[ax];
+    HV *seen;
+    /* A temporary buffer for number stringification */
+    SV *keysv = sv_newmortal();
+
+    if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
+        /* Optimise for the case of the empty list or a defined nonmagic
+         * singleton. Leave a singleton magical||undef for the regular case */
+        retcount = items;
+        goto finish;
+    }
+
+    sv_2mortal((SV *)(seen = newHV()));
+
+    for(index = 0 ; index < items ; index++) {
+        SV *arg = args[index];
+        NV nv_arg;
 #ifdef HV_FETCH_EMPTY_HE
-            HE *he;
+        HE* he;
 #endif
 
-            if(SvGAMAGIC(arg))
-                /* clone the value so we don't invoke magic again */
-                arg = sv_mortalcopy(arg);
+        if(SvGAMAGIC(arg))
+            /* clone the value so we don't invoke magic again */
+            arg = sv_mortalcopy(arg);
 
-            if(ix == 2 && !SvOK(arg)) {
-                /* special handling of undef for uniq() */
-                if(seen_undef)
-                    continue;
+        if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) {
+#if PERL_VERSION >= 8
+            SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */
+#else
+            SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */
+#endif
+        }
+#if NVSIZE > IVSIZE                          /* $Config{nvsize} > $Config{ivsize} */
+        /* Avoid altering arg's flags */ 
+        if(SvUOK(arg))      nv_arg = (NV)SvUV(arg);
+        else if(SvIOK(arg)) nv_arg = (NV)SvIV(arg);
+        else                nv_arg = SvNV(arg);
+
+        /* use 0 for all zeros */
+        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);
+#ifdef NV_IS_DOUBLEDOUBLE
+        /* If the least significant double is zero, it could be either 0.0     *
+         * or -0.0. We therefore ignore the least significant double and       *
+         * assign to keysv the bytes of the most significant double only.      */
+        else if(nv_arg == (double)nv_arg) {
+            double double_arg = (double)nv_arg;
+            sv_setpvn(keysv, (char *) &double_arg, 8);
+        }
+#endif
+        else {
+            /* Use the byte structure of the NV.                               *
+             * ACTUAL_NVSIZE == sizeof(NV) minus the number of bytes           *
+             * that are allocated but never used. (It is only the 10-byte      *
+             * extended precision long double that allocates bytes that are    *
+             * never used. For all other NV types ACTUAL_NVSIZE == sizeof(NV). */
+            sv_setpvn(keysv, (char *) &nv_arg, ACTUAL_NVSIZE);  
+        }
+#else                                    /* $Config{nvsize} == $Config{ivsize} == 8 */ 
+        if( SvIOK(arg) || !SvOK(arg) ) {
 
-                seen_undef++;
+            /* It doesn't matter if SvUOK(arg) is TRUE */
+            IV iv = SvIV(arg);
 
-                if(GIMME_V == G_ARRAY)
-                    ST(retcount) = arg;
-                retcount++;
-                continue;
+            /* use "0" for all zeros */
+            if(iv == 0) sv_setpvs(keysv, "0");
+
+            else {
+                int uok = SvUOK(arg);
+                int sign = ( iv > 0 || uok ) ? 1 : -1;
+
+                /* Set keysv to the bytes of SvNV(arg) if and only if the integer value  *
+                 * held by arg can be represented exactly as a double - ie if there are  *
+                 * no more than 51 bits between its least significant set bit and its    *
+                 * most significant set bit.                                             *
+                 * The neatest approach I could find was provided by roboticus at:       *
+                 *     https://www.perlmonks.org/?node_id=11113490                       *
+                 * First, identify the lowest set bit and assign its value to an IV.     *
+                 * Note that this value will always be > 0, and always a power of 2.     */
+                IV lowest_set = iv & -iv;
+
+                /* Second, shift it left 53 bits to get location of the first bit        *
+                 * beyond arg's highest "allowed" set bit.                                                    *
+                 * NOTE: If lowest set bit is initially far enough left, then this left  *
+                 * shift operation will result in a value of 0, which is fine.           *
+                 * Then subtract 1 so that all of the ("allowed") bits below the set bit *
+                 * are 1 && all other ("disallowed") bits are set to 0.                  *
+                 * (If the value prior to subtraction was 0, then subtracting 1 will set *
+                 * all bits - which is also fine.)                                       */ 
+                UV valid_bits = (lowest_set << 53) - 1;
+
+                /* The value of arg can be exactly represented by a double unless one    *
+                 * or more of its "disallowed" bits are set - ie if iv & (~valid_bits)   *
+                 * is untrue. However, if (iv < 0 && !SvUOK(arg)) we need to multiply iv *
+                 * by -1 prior to performing that '&' operation - so multiply iv by sign.*/
+                if( !((iv * sign) & (~valid_bits)) ) {
+                    /* Avoid altering arg's flags */
+                    nv_arg = uok ? (NV)SvUV(arg) : (NV)SvIV(arg); 
+                    sv_setpvn(keysv, (char *) &nv_arg, 8);
+                }          
+                else {
+                    /* Read in the bytes, rather than the numeric value of the IV/UV as  *
+                     * this is more efficient, despite having to sv_catpvn an extra byte.*/
+                    sv_setpvn(keysv, (char *) &iv, 8);
+                    /* We add an extra byte to distinguish between an IV/UV and an NV.   *
+                     * We also use that byte to distinguish between a -ve IV and a UV.   */
+                    if(uok) sv_catpvn(keysv, "U", 1);
+                    else    sv_catpvn(keysv, "I", 1);
+                }
             }
+        }
+        else {
+            nv_arg = SvNV(arg);
+
+            /* for NaN, use the platform's normal stringification */
+            if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
+
+            /* use "0" for all zeros */
+            else if(nv_arg == 0) sv_setpvs(keysv, "0");
+            else sv_setpvn(keysv, (char *) &nv_arg, 8);
+        }
+#endif
 #ifdef HV_FETCH_EMPTY_HE
-            he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
-            if (HeVAL(he))
-                continue;
+        he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
+        if (HeVAL(he))
+            continue;
 
-            HeVAL(he) = &PL_sv_undef;
+        HeVAL(he) = &PL_sv_undef;
 #else
-            if (hv_exists_ent(seen, arg, 0))
-                continue;
+        if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
+            continue;
 
-            hv_store_ent(seen, arg, &PL_sv_yes, 0);
+        hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
 #endif
 
-            if(GIMME_V == G_ARRAY)
-                ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
-            retcount++;
-        }
+        if(GIMME_V == G_ARRAY)
+            ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
+        retcount++;
     }
 
   finish:
index 37bd104..3dc13d7 100644 (file)
@@ -6,12 +6,13 @@ 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];
 
-WriteMakefile(
+my %params = (
   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',
 
@@ -29,7 +30,9 @@ WriteMakefile(
     ? ()
     : (
       INSTALLDIRS      => ($] < 5.011 ? q[perl] : q[site]),
-      PREREQ_PM        => {'Test::More' => 0,},
+      TEST_REQUIRES => {
+        'Test::More' => 0,
+      },
       (eval { ExtUtils::MakeMaker->VERSION(6.31) } ? (LICENSE => 'perl') : ()),
       (eval { ExtUtils::MakeMaker->VERSION(6.48) } ? (MIN_PERL_VERSION => '5.006') : ()),
       ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? (
@@ -54,3 +57,18 @@ WriteMakefile(
     )
   ),
 );
+
+if ($params{TEST_REQUIRES} and !eval { ExtUtils::MakeMaker->VERSION(6.64) }) {
+    $params{BUILD_REQUIRES} = {
+        %{$params{BUILD_REQUIRES} || {}},
+        %{delete $params{TEST_REQUIRES}},
+    };
+}
+if ($params{BUILD_REQUIRES} and !eval { ExtUtils::MakeMaker->VERSION(6.5503) }) {
+    $params{PREREQ_PM} = {
+        %{$params{PREREQ_PM} || {}},
+        %{delete $params{BUILD_REQUIRES}},
+    };
+}
+
+WriteMakefile(%params);
index e1b66c6..e582d60 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 uniqint uniqnum uniqstr
   head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
 );
-our $VERSION    = "1.53";
+our $VERSION    = "1.55";
 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,13 +51,13 @@ 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
 
       pairs unpairs pairkeys pairvalues pairfirst pairgrep pairmap
 
-      shuffle uniq uniqnum uniqstr
+      shuffle uniq uniqint uniqnum uniqstr
     );
 
 =head1 DESCRIPTION
@@ -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
@@ -509,6 +553,28 @@ string, and no warning will be produced. It is left as-is in the returned
 list. Subsequent C<undef> values are still considered identical to the first,
 and will be removed.
 
+=head2 uniqint
+
+    my @subset = uniqint @values
+
+I<Since version 1.55.>
+
+Filters a list of values to remove subsequent duplicates, as judged by an
+integer numerical equality test. Preserves the order of unique elements, and
+retains the first value of any duplicate set. Values in the returned list will
+be coerced into integers.
+
+    my $count = uniqint @values
+
+In scalar context, returns the number of elements that would have been
+returned as a list.
+
+Note that C<undef> is treated much as other numerical operations treat it; it
+compares equal to zero but additionally produces a warning if such warnings
+are enabled (C<use warnings 'uninitialized';>). In addition, an C<undef> in
+the returned list is coerced into a numerical zero, so that the entire list of
+values returned by C<uniqint> are well-behaved as integers.
+
 =head2 uniqnum
 
     my @subset = uniqnum @values
@@ -587,6 +653,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..88f663f 100644 (file)
@@ -3,7 +3,7 @@ use strict;
 use warnings;
 use List::Util;
 
-our $VERSION = "1.53";       # FIXUP
+our $VERSION = "1.55";       # FIXUP
 $VERSION =~ tr/_//d;         # FIXUP
 
 1;
index bf670c9..a7345aa 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.55";
 $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..d7b59ae 100644 (file)
@@ -15,7 +15,7 @@ our @EXPORT_OK = qw(
   subname set_subname
 );
 
-our $VERSION    = "1.53";
+our $VERSION    = "1.55";
 $VERSION =~ tr/_//d;
 
 require List::Util; # as it has the XS
index 2ae3679..49eb355 100644 (file)
@@ -8,23 +8,23 @@ use Scalar::Util qw(blessed);
 
 my $t;
 
-ok(!defined blessed(undef),    'undef is not blessed');
-ok(!defined blessed(1),                'Numbers are not blessed');
-ok(!defined blessed('A'),      'Strings are not blessed');
-ok(!defined blessed({}),       'Unblessed HASH-ref');
-ok(!defined blessed([]),       'Unblessed ARRAY-ref');
-ok(!defined blessed(\$t),      'Unblessed SCALAR-ref');
+ok(!defined blessed(undef), 'undef is not blessed');
+ok(!defined blessed(1),     'Numbers are not blessed');
+ok(!defined blessed('A'),   'Strings are not blessed');
+ok(!defined blessed({}),    'Unblessed HASH-ref');
+ok(!defined blessed([]),    'Unblessed ARRAY-ref');
+ok(!defined blessed(\$t),   'Unblessed SCALAR-ref');
 
 my $x;
 
 $x = bless [], "ABC";
-is(blessed($x), "ABC", 'blessed ARRAY-ref');
+is(blessed($x), "ABC", 'blessed ARRAY-ref');
 
 $x = bless {}, "DEF";
-is(blessed($x), "DEF", 'blessed HASH-ref');
+is(blessed($x), "DEF", 'blessed HASH-ref');
 
 $x = bless {}, "0";
-cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref');
+cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref');
 
 {
   my $blessed = do {
index 08dff11..bd77c96 100644 (file)
@@ -5,8 +5,8 @@ use warnings;
 
 use Scalar::Util ();
 use Test::More  (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL)
-                       ? (skip_all => 'dualvar requires XS version')
-                       : (tests => 41);
+    ? (skip_all => 'dualvar requires XS version')
+    : (tests => 41);
 use Config;
 
 Scalar::Util->import('dualvar');
@@ -15,44 +15,44 @@ Scalar::Util->import('isdual');
 my $var;
 $var = dualvar( 2.2,"string");
 
-ok( isdual($var),      'Is a dualvar');
-ok( $var == 2.2,       'Numeric value');
-ok( $var eq "string",  'String value');
+ok( isdual($var), 'Is a dualvar');
+ok( $var == 2.2, 'Numeric value');
+ok( $var eq "string", 'String value');
 
 my $var2 = $var;
 
-ok( isdual($var2),     'Is a dualvar');
-ok( $var2 == 2.2,      'copy Numeric value');
-ok( $var2 eq "string", 'copy String value');
+ok( isdual($var2), 'Is a dualvar');
+ok( $var2 == 2.2, 'copy Numeric value');
+ok( $var2 eq "string", 'copy String value');
 
 $var++;
 
-ok( ! isdual($var),    'No longer dualvar');
-ok( $var == 3.2,       'inc Numeric value');
-ok( $var ne "string",  'inc String value');
+ok( ! isdual($var), 'No longer dualvar');
+ok( $var == 3.2, 'inc Numeric value');
+ok( $var ne "string", 'inc String value');
 
 my $numstr = "10.2";
 my $numtmp = int($numstr); # use $numstr as an int
 
 $var = dualvar($numstr, "");
 
-ok( isdual($var),      'Is a dualvar');
-ok( $var == $numstr,   'NV');
+ok( isdual($var), 'Is a dualvar');
+ok( $var == $numstr, 'NV');
 
 SKIP: {
   skip("dualvar with UV value known to fail with $]",3) if $] < 5.006_001;
   my $bits = ($Config{'use64bitint'}) ? 63 : 31;
   $var = dualvar(1<<$bits, "");
-  ok( isdual($var),            'Is a dualvar');
-  ok( $var == (1<<$bits),      'UV 1');
-  ok( $var > 0,                        'UV 2');
+  ok( isdual($var), 'Is a dualvar');
+  ok( $var == (1<<$bits), 'UV 1');
+  ok( $var > 0, 'UV 2');
 }
 
 # Create a dualvar "the old fashioned way"
 $var = "10";
-ok( ! isdual($var),    'Not a dualvar');
+ok( ! isdual($var), 'Not a dualvar');
 my $foo = $var + 0;
-ok( isdual($var),      'Is a dualvar');
+ok( isdual($var), 'Is a dualvar');
 
 {
   package Tied;
@@ -63,9 +63,9 @@ ok( isdual($var),     'Is a dualvar');
 
 tie my $tied, 'Tied';
 $var = dualvar($tied, "ok");
-ok(isdual($var),       'Is a dualvar');
-ok($var == 7.5,                'Tied num');
-ok($var eq 'ok',       'Tied str');
+ok(isdual($var), 'Is a dualvar');
+ok($var == 7.5, 'Tied num');
+ok($var eq 'ok', 'Tied str');
 
 
 SKIP: {
index cb5d2cc..3c5f212 100644 (file)
@@ -13,10 +13,10 @@ BEGIN { $^P |= 0x210 }
 use if $] >= 5.016, feature => 'unicode_eval';
 
 if ($] >= 5.008) {
-       my $builder = Test::More->builder;
-       binmode $builder->output,         ":encoding(utf8)";
-       binmode $builder->failure_output, ":encoding(utf8)";
-       binmode $builder->todo_output,    ":encoding(utf8)";
+    my $builder = Test::More->builder;
+    binmode $builder->output,         ":encoding(utf8)";
+    binmode $builder->failure_output, ":encoding(utf8)";
+    binmode $builder->todo_output,    ":encoding(utf8)";
 }
 
 sub compile_named_sub {
index ba7726a..3f008e7 100644 (file)
@@ -5,10 +5,10 @@ use warnings;
 
 use List::Util qw(first);
 use Test::More;
-plan tests => 22 + ($::PERL_ONLY ? 0 : 2);
+plan tests => 24;
 my $v;
 
-ok(defined &first,     'defined');
+ok(defined &first, 'defined');
 
 $v = first { 8 == ($_ - 1) } 9,4,5,6;
 is($v, 9, 'one more than 8');
@@ -20,7 +20,7 @@ $v = first { 0 };
 is($v, undef, 'no args');
 
 $v = first { $_->[1] le "e" and "e" le $_->[2] }
-               [qw(a b c)], [qw(d e f)], [qw(g h i)];
+    [qw(a b c)], [qw(d e f)], [qw(g h i)];
 is_deeply($v, [qw(d e f)], 'reference args');
 
 # Check that eval{} inside the block works correctly
@@ -89,11 +89,9 @@ SKIP: {
     is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged");
 }
 
-# The remainder of the tests are only relevant for the XS
-# implementation. The Perl-only implementation behaves differently
-# (and more flexibly) in a way that we can't emulate from XS.
-if (!$::PERL_ONLY) { SKIP: {
-
+# These tests are only relevant for the real multicall implementation. The
+# psuedo-multicall implementation behaves differently.
+SKIP: {
     $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
     skip("Poor man's MULTICALL can't cope", 2)
       if !$List::Util::REAL_MULTICALL;
@@ -105,8 +103,7 @@ if (!$::PERL_ONLY) { SKIP: {
     # Can we goto a subroutine?
     eval {()=first{goto sub{}} 1,2;};
     like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
-
-} }
+}
 
 use constant XSUBC_TRUE  => 1;
 use constant XSUBC_FALSE => 0;
index 9d345aa..3649d41 100644 (file)
@@ -6,18 +6,18 @@ use warnings;
 $|=1;
 use Scalar::Util ();
 use Test::More  (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL)
-                       ? (skip_all => 'isvstring requires XS version')
-                       : (tests => 3);
+    ? (skip_all => 'isvstring requires XS version')
+    : (tests => 3);
 
 Scalar::Util->import(qw[isvstring]);
 
 my $vs = ord("A") == 193 ? 241.75.240 : 49.46.48;
 
-ok( $vs == "1.0",      'dotted num');
-ok( isvstring($vs),    'isvstring');
+ok( $vs == "1.0", 'dotted num');
+ok( isvstring($vs), 'isvstring');
 
 my $sv = "1.0";
-ok( !isvstring($sv),   'not isvstring');
+ok( !isvstring($sv), 'not isvstring');
 
 
 
index df9ea3a..8458344 100644 (file)
@@ -10,18 +10,18 @@ foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) {
   ok(looks_like_number($num), "'$num'");
 }
 
-is(!!looks_like_number("Inf"),     $] >= 5.006001,     'Inf');
-is(!!looks_like_number("Infinity"), $] >= 5.008,       'Infinity');
-is(!!looks_like_number("NaN"),     $] >= 5.008,        'NaN');
-is(!!looks_like_number("foo"),     '',                 'foo');
-is(!!looks_like_number(undef),     '',                 'undef');
-is(!!looks_like_number({}),        '',                 'HASH Ref');
-is(!!looks_like_number([]),        '',                 'ARRAY Ref');
+is(!!looks_like_number("Inf"),      $] >= 5.006001, 'Inf');
+is(!!looks_like_number("Infinity"), $] >= 5.008,    'Infinity');
+is(!!looks_like_number("NaN"),      $] >= 5.008,    'NaN');
+is(!!looks_like_number("foo"),      '',             'foo');
+is(!!looks_like_number(undef),      '',             'undef');
+is(!!looks_like_number({}),         '',             'HASH Ref');
+is(!!looks_like_number([]),         '',             'ARRAY Ref');
 
 use Math::BigInt;
 my $bi = Math::BigInt->new('1234567890');
-is(!!looks_like_number($bi),       1,                  'Math::BigInt');
-is(!!looks_like_number("$bi"),     1,                  'Stringified Math::BigInt');
+is(!!looks_like_number($bi),        1,              'Math::BigInt');
+is(!!looks_like_number("$bi"),      1,              'Stringified Math::BigInt');
 
 { package Foo;
 sub TIEHASH { bless {} }
@@ -29,9 +29,9 @@ sub FETCH { $_[1] }
 }
 my %foo;
 tie %foo, 'Foo';
-is(!!looks_like_number($foo{'abc'}),       '',                 'Tied');
-is(!!looks_like_number($foo{'123'}),       1,                  'Tied');
+is(!!looks_like_number($foo{'abc'}),  '',           'Tied');
+is(!!looks_like_number($foo{'123'}),  1,            'Tied');
 
-is(!!looks_like_number("\x{1815}"),       '',                  'MONGOLIAN DIGIT FIVE');
+is(!!looks_like_number("\x{1815}"),   '',           'MONGOLIAN DIGIT FIVE');
 
 # We should copy some of perl core tests like t/base/num.t here
index c8e19ff..1333ade 100644 (file)
@@ -6,26 +6,26 @@ use warnings;
 use Scalar::Util qw(readonly);
 use Test::More tests => 11;
 
-ok( readonly(1),       'number constant');
+ok( readonly(1), 'number constant');
 
 my $var = 2;
 
-ok( !readonly($var),   'number variable');
-is( $var,      2,      'no change to number variable');
+ok( !readonly($var), 'number variable');
+is( $var, 2, 'no change to number variable');
 
-ok( readonly("fred"),  'string constant');
+ok( readonly("fred"), 'string constant');
 
 $var = "fred";
 
-ok( !readonly($var),   'string variable');
-is( $var,      'fred', 'no change to string variable');
+ok( !readonly($var),  'string variable');
+is( $var, 'fred', 'no change to string variable');
 
 $var = \2;
 
-ok( !readonly($var),   'reference to constant');
-ok( readonly($$var),   'de-reference to constant');
+ok( !readonly($var), 'reference to constant');
+ok( readonly($$var), 'de-reference to constant');
 
-ok( !readonly(*STDOUT),        'glob');
+ok( !readonly(*STDOUT), 'glob');
 
 sub try
 {
index 848c34f..67fdbaa 100644 (file)
@@ -5,25 +5,25 @@ use warnings;
 
 use List::Util qw(reduce min);
 use Test::More;
-plan tests => 30 + ($::PERL_ONLY ? 0 : 2);
+plan tests => 33;
 
 my $v = reduce {};
 
-is( $v,        undef,  'no args');
+is( $v, undef, 'no args');
 
 $v = reduce { $a / $b } 756,3,7,4;
-is( $v,        9,      '4-arg divide');
+is( $v, 9, '4-arg divide');
 
 $v = reduce { $a / $b } 6;
-is( $v,        6,      'one arg');
+is( $v, 6, 'one arg');
 
 my @a = map { rand } 0 .. 20;
 $v = reduce { $a < $b ? $a : $b } @a;
-is( $v,        min(@a),        'min');
+is( $v, min(@a), 'min');
 
 @a = map { pack("C", int(rand(256))) } 0 .. 20;
 $v = reduce { $a . $b } @a;
-is( $v,        join("",@a),    'concat');
+is( $v, join("",@a), 'concat');
 
 sub add {
   my($aa, $bb) = @_;
@@ -31,26 +31,26 @@ sub add {
 }
 
 $v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1;
-is( $v,        6,      'call sub');
+is( $v, 6, 'call sub');
 
 # Check that eval{} inside the block works correctly
 $v = reduce { eval { die }; $a + $b } 0,1,2,3,4;
-is( $v,        10,     'use eval{}');
+is( $v, 10, 'use eval{}');
 
 $v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
 ok($v, 'die');
 
 sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 }
 ($v) = foobar();
-is( $v,        3,      'scalar context');
+is( $v, 3, 'scalar context');
 
 sub add2 { $a + $b }
 
 $v = reduce \&add2, 1,2,3;
-is( $v,        6,      'sub reference');
+is( $v, 6, 'sub reference');
 
 $v = reduce { add2() } 3,4,5;
-is( $v, 12,    'call sub');
+is( $v, 12, 'call sub');
 
 
 $v = reduce { eval "$a + $b" } 1,2,3;
@@ -125,11 +125,9 @@ SKIP: {
   is($ok, '', 'Not a subroutine reference');
 }
 
-# The remainder of the tests are only relevant for the XS
-# implementation. The Perl-only implementation behaves differently
-# (and more flexibly) in a way that we can't emulate from XS.
-if (!$::PERL_ONLY) { SKIP: {
-
+# These tests are only relevant for the real multicall implementation. The
+# psuedo-multicall implementation behaves differently.
+SKIP: {
     $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
     skip("Poor man's MULTICALL can't cope", 2)
       if !$List::Util::REAL_MULTICALL;
@@ -141,8 +139,12 @@ if (!$::PERL_ONLY) { SKIP: {
     # Can we goto a subroutine?
     eval {()=reduce{goto sub{}} 1,2;};
     like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
+}
 
-} }
+{
+  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;
@@ -162,4 +164,4 @@ ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
 
 my @names = ("a\x{100}c", "d\x{101}efgh", 'ijk');
 my $longest = reduce { length($a) > length($b) ? $a : $b } @names;
-is( length($longest),  6,      'missing SMG rt#121992');
+is( length($longest), 6, 'missing SMG rt#121992');
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..fd669f1
--- /dev/null
@@ -0,0 +1,51 @@
+#!./perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+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' );
+}
index 8d7c441..91b6fa9 100644 (file)
@@ -64,9 +64,10 @@ foreach my $r ({}, \$t, [], \*F, sub {}) {
 
 package FooBar;
 
-use overload  '0+' => sub { 10 },
-               '+' => sub { 10 + $_[1] },
-               '""' => sub { "10" };
+use overload
+    '0+'  => sub { 10 },
+    '+'   => sub { 10 + $_[1] },
+    '""'  => sub { "10" };
 
 package MyTie;
 
@@ -85,21 +86,21 @@ use Scalar::Util qw(refaddr);
 
 sub TIEHASH
 {
-       my $pkg = shift;
-       return bless [ @_ ], $pkg;
+    my $pkg = shift;
+    return bless [ @_ ], $pkg;
 }
 sub FETCH
 {
-       my $self = shift;
-       my $key = shift;
-       my ($underlying) = @$self;
-       return $underlying->{refaddr($key)};
+    my $self = shift;
+    my $key = shift;
+    my ($underlying) = @$self;
+    return $underlying->{refaddr($key)};
 }
 sub STORE
 {
-       my $self = shift;
-       my $key = shift;
-       my $value = shift;
-       my ($underlying) = @$self;
-       return ($underlying->{refaddr($key)} = $key);
+    my $self = shift;
+    my $key = shift;
+    my $value = shift;
+    my ($underlying) = @$self;
+    return ($underlying->{refaddr($key)} = $key);
 }
index a40e414..2fefd8f 100644 (file)
@@ -18,18 +18,18 @@ $s = undef; # SvTYPE($s) is SVt_RV, but SvROK($s) is false
 
 my $t;
 my @test = (
[ undef, 1,           'number'        ],
[ undef, 'A',         'string'        ],
[ HASH   => {},       'HASH ref'      ],
[ ARRAY  => [],       'ARRAY ref'     ],
[ SCALAR => \$t,      'SCALAR ref'    ],
[ SCALAR => \$s,      'SCALAR ref (but SVt_RV)' ],
[ REF    => \(\$t),   'REF ref'       ],
[ GLOB   => \*F,      'tied GLOB ref' ],
[ GLOB   => gensym,   'GLOB ref'      ],
[ CODE   => sub {},   'CODE ref'      ],
[ IO     => *STDIN{IO},'IO ref'        ],
[ $RE    => qr/x/,     'REGEEXP'       ],
 [ undef, 1,             'number' ],
 [ undef, 'A',           'string' ],
 [ HASH   => {},         'HASH ref' ],
 [ ARRAY  => [],         'ARRAY ref' ],
 [ SCALAR => \$t,        'SCALAR ref' ],
 [ SCALAR => \$s,        'SCALAR ref (but SVt_RV)' ],
 [ REF    => \(\$t),     'REF ref' ],
 [ GLOB   => \*F,        'tied GLOB ref' ],
 [ GLOB   => gensym,     'GLOB ref' ],
 [ CODE   => sub {},     'CODE ref' ],
 [ IO     => *STDIN{IO}, 'IO ref' ],
 [ $RE    => qr/x/,      'REGEEXP' ],
 );
 
 foreach my $test (@test) {
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..0927571
--- /dev/null
@@ -0,0 +1,73 @@
+#!./perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+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' ),
+    join( "", sample 5, 'A'..'Z' ),
+    'rigged rand() yields predictable output'
+  );
+}
index e9b653a..8d70a77 100644 (file)
@@ -5,48 +5,48 @@ use warnings;
 
 use Scalar::Util ();
 use Test::More  (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL)
-                       ? (skip_all => 'set_prototype requires XS version')
-                       : (tests => 14);
+    ? (skip_all => 'set_prototype requires XS version')
+    : (tests => 14);
 
 Scalar::Util->import('set_prototype');
 
 sub f { }
-is( prototype('f'),    undef,  'no prototype');
+is( prototype('f'), undef, 'no prototype');
 
 my $r = set_prototype(\&f,'$');
-is( prototype('f'),    '$',    'set prototype');
-is( $r,                        \&f,    'return value');
+is( prototype('f'), '$', 'set prototype');
+is( $r, \&f, 'return value');
 
 set_prototype(\&f,undef);
-is( prototype('f'),    undef,  'remove prototype');
+is( prototype('f'), undef, 'remove prototype');
 
 set_prototype(\&f,'');
-is( prototype('f'),    '',     'empty prototype');
+is( prototype('f'), '', 'empty prototype');
 
 sub g (@) { }
-is( prototype('g'),    '@',    '@ prototype');
+is( prototype('g'), '@', '@ prototype');
 
 set_prototype(\&g,undef);
-is( prototype('g'),    undef,  'remove prototype');
+is( prototype('g'), undef, 'remove prototype');
 
 sub stub;
-is( prototype('stub'), undef,  'non existing sub');
+is( prototype('stub'), undef, 'non existing sub');
 
 set_prototype(\&stub,'$$$');
-is( prototype('stub'), '$$$',  'change non existing sub');
+is( prototype('stub'), '$$$', 'change non existing sub');
 
 sub f_decl ($$$$);
-is( prototype('f_decl'),       '$$$$', 'forward declaration');
+is( prototype('f_decl'), '$$$$', 'forward declaration');
 
 set_prototype(\&f_decl,'\%');
-is( prototype('f_decl'),       '\%',   'change forward declaration');
+is( prototype('f_decl'), '\%', 'change forward declaration');
 
 eval { &set_prototype( 'f', '' ); };
 print "not " unless 
-ok($@ =~ /^set_prototype: not a reference/,    'not a reference');
+ok($@ =~ /^set_prototype: not a reference/, 'not a reference');
 
 eval { &set_prototype( \'f', '' ); };
-ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference');
+ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference');
 
 # RT 72080
 
index dff9637..7135b51 100644 (file)
@@ -3,24 +3,35 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6;
+use Test::More tests => 7;
 
 use List::Util qw(shuffle);
 
 my @r;
 
 @r = shuffle();
-ok( !@r,       'no args');
+ok( !@r, 'no args');
 
 @r = shuffle(9);
-is( 0+@r,      1,      '1 in 1 out');
-is( $r[0],     9,      'one arg');
+is( 0+@r, 1, '1 in 1 out');
+is( $r[0], 9, 'one arg');
 
 my @in = 1..100;
 @r = shuffle(@in);
-is( 0+@r,      0+@in,  'arg count');
+is( 0+@r, 0+@in, 'arg count');
 
-isnt( "@r",    "@in",  'result different to args');
+isnt( "@r", "@in", 'result different to args');
 
 my @s = sort { $a <=> $b } @r;
-is( "@in",     "@s",   'values');
+is( "@in", "@s", 'values');
+
+{
+  local $List::Util::RAND = sub { 4/10 }; # chosen by a fair die
+
+  @r = shuffle(1..10);
+  is_deeply(
+    [ shuffle(1..10) ],
+    [ shuffle(1..10) ],
+    'rigged rand() yields predictable output'
+  );
+}
index e2c416d..5247a37 100644 (file)
@@ -9,7 +9,7 @@ use Config;
 use List::Util qw(sum);
 
 my $v = sum;
-is( $v,        undef,  'no args');
+is( $v, undef, 'no args');
 
 $v = sum(9);
 is( $v, 9, 'one arg');
index fb83c86..1197b29 100644 (file)
@@ -13,10 +13,10 @@ my $var = 2;
 
 ok( !tainted($var), 'known variable');
 
-ok( tainted($^X),      'interpreter variable');
+ok( tainted($^X), 'interpreter variable');
 
 $var = $^X;
-ok( tainted($var),     'copy of interpreter variable');
+ok( tainted($var), 'copy of interpreter variable');
 
 {
     package Tainted;
index 8e76f21..c55f03a 100644 (file)
@@ -2,9 +2,9 @@
 
 use strict;
 use warnings;
-
-use Test::More tests => 33;
-use List::Util qw( uniqnum uniqstr uniq );
+use Config; # to determine ivsize
+use Test::More tests => 31;
+use List::Util qw( uniqstr uniqint uniq );
 
 use Tie::Array;
 
@@ -67,69 +67,52 @@ SKIP: {
     is( $warnings, "", 'No warnings are printed when handling Unicode strings' );
 }
 
-is_deeply( [ uniqnum qw( 1 1.0 1E0 2 3 ) ],
-           [ 1, 2, 3 ],
-           'uniqnum compares numbers' );
-
-is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ],
-           [ 1, 1.1, 1.2, 1.3 ],
-           'uniqnum distinguishes floats' );
-
-{
-    my @nums = map $_+0.1, 1e7..1e7+5;
-    is_deeply( [ uniqnum @nums ],
-               [ @nums ],
-               'uniqnum distinguishes large floats' );
-
-    my @strings = map "$_", @nums;
-    is_deeply( [ uniqnum @strings ],
-               [ @strings ],
-               'uniqnum distinguishes large floats (stringified)' );
-}
-
-# Hard to know for sure what an Inf is going to be. Lets make one
-my $Inf = 0 + 1E1000;
-my $NaN;
-$Inf **= 1000 while ( $NaN = $Inf - $Inf ) == $NaN;
-
-is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ],
-           [ 0, 1, 12345, $Inf, -$Inf, $NaN ],
-           'uniqnum preserves the special values of +-Inf and Nan' );
-
-SKIP: {
-    my $maxuint = ~0;
-    my $maxint = ~0 >> 1;
-    my $minint = -(~0 >> 1) - 1;
-
-    my @nums = ($maxuint, $maxuint-1, -1, $Inf, $NaN, $maxint, $minint, 1 );
-
-    is_deeply( [ uniqnum @nums, 1.0 ],
-               [ @nums ],
-               'uniqnum preserves uniqness of full integer range' );
+is_deeply( [ uniqint ],
+           [],
+           'uniqint of empty list' );
 
-    my @strs = map "$_", @nums;
+is_deeply( [ uniqint 5, 5 ],
+           [ 5 ],
+           'uniqint of repeated-element list' );
 
-    skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 )
-        if $maxuint !~ /\A[0-9]+\z/;
+is_deeply( [ uniqint 1, 2, 1, 3 ],
+           [ 1, 2, 3 ],
+           'uniqint removes subsequent duplicates' );
 
-    is_deeply( [ uniqnum @strs, "1.0" ],
-               [ @strs ],
-               'uniqnum preserves uniqness of full integer range (stringified)' );
-}
+is_deeply( [ uniqint 6.1, 6.2, 6.3 ],
+           [ 6 ],
+           'uniqint compares as and returns integers' );
 
 {
     my $warnings = "";
     local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
 
-    is_deeply( [ uniqnum 0, undef ],
+    is_deeply( [ uniqint 0, undef ],
                [ 0 ],
-               'uniqnum considers undef and zero equivalent' );
+               'uniqint considers undef and zero equivalent' );
 
-    ok( length $warnings, 'uniqnum on undef yields a warning' );
+    ok( length $warnings, 'uniqint on undef yields a warning' );
 
-    is_deeply( [ uniqnum undef ],
+    is_deeply( [ uniqint undef ],
                [ 0 ],
-               'uniqnum on undef coerces to zero' );
+               'uniqint on undef coerces to zero' );
+}
+
+SKIP: {
+    skip('UVs are not reliable on this perl version', 2) unless $] ge "5.008000";
+
+    my $maxbits = $Config{ivsize} * 8 - 1;
+
+    # An integer guaranteed to be a UV
+    my $uv = 1 << $maxbits;
+    is_deeply( [ uniqint $uv, $uv + 1 ],
+               [ $uv, $uv + 1 ],
+               'uniqint copes with UVs' );
+
+    my $nvuv = 2 ** $maxbits;
+    is_deeply( [ uniqint $nvuv, 0 ],
+               [ int($nvuv), 0 ],
+               'uniqint copes with NVUV dualvars' );
 }
 
 is_deeply( [ uniq () ],
@@ -169,24 +152,21 @@ is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' );
                'uniqstr respects stringify overload' );
 }
 
-{
-    package Numify;
+SKIP: {
+    skip('int overload requires perl version 5.8.0', 1) unless $] ge "5.008000";
 
-    use overload '0+' => sub { return $_[0]->{num} };
+    package Googol;
 
-    sub new { bless { num => $_[1] }, $_[0] }
+    use overload '""' => sub { "1" . ( "0"x100 ) },
+                 'int' => sub { $_[0] };
 
-    package main;
-    use Scalar::Util qw( refaddr );
+    sub new { bless {}, $_[0] }
 
-    my @nums = map { Numify->new( $_ ) } qw( 2 2 5 );
+    package main;
 
-    # is_deeply wants to use eq overloading
-    my @ret = uniqnum @nums;
-    ok( scalar @ret == 2 &&
-        refaddr $ret[0] == refaddr $nums[0] &&
-        refaddr $ret[1] == refaddr $nums[2],
-               'uniqnum respects numify overload' );
+    is_deeply( [ uniqint( Googol->new, Googol->new ) ],
+               [ "1" . ( "0"x100 ) ],
+               'uniqint respects int overload' );
 }
 
 {
@@ -219,11 +199,6 @@ is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' );
     is_deeply( [ uniqstr $1, $2, $3 ],
                [qw( a b )],
                'uniqstr handles magic' );
-
-    "1 1 2" =~ m/(.) (.) (.)/;
-    is_deeply( [ uniqnum $1, $2, $3 ],
-               [ 1, 2 ],
-               'uniqnum handles magic' );
 }
 
 {
diff --git a/cpan/Scalar-List-Utils/t/uniqnum.t b/cpan/Scalar-List-Utils/t/uniqnum.t
new file mode 100644 (file)
index 0000000..d34d2c7
--- /dev/null
@@ -0,0 +1,329 @@
+#!./perl
+
+use strict;
+use warnings;
+use Config; # to determine nvsize
+use Test::More tests => 23;
+use List::Util qw( uniqnum );
+
+is_deeply( [ uniqnum qw( 1 1.0 1E0 2 3 ) ],
+           [ 1, 2, 3 ],
+           'uniqnum compares numbers' );
+
+is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ],
+           [ 1, 1.1, 1.2, 1.3 ],
+           'uniqnum distinguishes floats' );
+
+{
+    my @nums = map $_+0.1, 1e7..1e7+5;
+    is_deeply( [ uniqnum @nums ],
+               [ @nums ],
+               'uniqnum distinguishes large floats' );
+
+    my @strings = map "$_", @nums;
+    is_deeply( [ uniqnum @strings ],
+               [ @strings ],
+               '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 1005.10228292019306452029161597769015 == 1005.1022829201930645202916159776901;
+
+    $uniq_count1 = uniqnum (1005.10228292019306452029161597769015,
+                            1005.1022829201930645202916159776901 );
+
+    $uniq_count2 = uniqnum('1005.10228292019306452029161597769015',
+                           '1005.1022829201930645202916159776901' );
+  }
+}
+
+else {
+  # NV is extended precision 'long double'
+
+  # The 2 values should be unequal - but just in case perl is buggy:
+  $equiv = 1 if 10.770329614269008063 == 10.7703296142690080625;
+
+  $uniq_count1 = uniqnum (10.770329614269008063,
+                          10.7703296142690080625 );
+
+  $uniq_count2 = uniqnum('10.770329614269008063',
+                         '10.7703296142690080625' );
+}
+
+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;      # maximum left shift for 32-bit unity
+
+if( $Config{ivsize} == 8 ) {
+  $ls       = 63; # maximum left shift for 64-bit unity
+}
+
+# Populate @in with UV-NV pairs of equivalent values.
+# Each of these values is exactly representable as 
+# either a UV or an NV.
+
+my @in = (1 << $ls, 2 ** $ls,
+          1 << ($ls - 3), 2 ** ($ls - 3),
+          5 << ($ls - 3), 5 * (2 ** ($ls - 3)));
+
+my @correct = (1 << $ls, 1 << ($ls - 3), 5 << ($ls -3));
+
+if( $Config{ivsize} == 8 && $Config{nvsize} == 8 ) {
+
+     # Add some more UV-NV pairs of equivalent values.
+     # Each of these values is exactly representable
+     # as either a UV or an NV.
+
+     push @in, ( 9007199254740991,     9.007199254740991e+15,
+                 9007199254740992,     9.007199254740992e+15,
+                 9223372036854774784,  9.223372036854774784e+18,
+                 18446744073709549568, 1.8446744073709549568e+19,
+                 18446744073709139968, 1.8446744073709139968e+19,
+                 100000000000262144,   1.00000000000262144e+17,
+                 100000000001310720,   1.0000000000131072e+17,
+                 144115188075593728,   1.44115188075593728e+17,
+                 -9007199254740991,     -9.007199254740991e+15,
+                 -9007199254740992,     -9.007199254740992e+15,
+                 -9223372036854774784,  -9.223372036854774784e+18,
+                 -18446744073709549568, -1.8446744073709549568e+19,
+                 -18446744073709139968, -1.8446744073709139968e+19,
+                 -100000000000262144,   -1.00000000000262144e+17,
+                 -100000000001310720,   -1.0000000000131072e+17,
+                 -144115188075593728,   -1.44115188075593728e+17 );
+
+     push @correct, ( 9007199254740991,
+                      9007199254740992,
+                      9223372036854774784,
+                      18446744073709549568,
+                      18446744073709139968,
+                      100000000000262144,
+                      100000000001310720,
+                      144115188075593728,
+                      -9007199254740991,
+                      -9007199254740992,
+                      -9223372036854774784,
+                      -18446744073709549568,
+                      -18446744073709139968,
+                      -100000000000262144,
+                      -100000000001310720,
+                      -144115188075593728 );
+}
+
+# uniqnum should discard each of the NVs as being a
+# duplicate of the preceding UV. 
+
+is_deeply( [ uniqnum @in],
+           [ @correct],
+           '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;
+$Inf **= 1000 while ( $NaN = $Inf - $Inf ) == $NaN;
+
+is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ],
+           [ 0, 1, 12345, $Inf, -$Inf, $NaN ],
+           'uniqnum preserves the special values of +-Inf and Nan' );
+
+SKIP: {
+    my $maxuint = ~0;
+    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;
+        }
+    }
+
+    is_deeply( [ uniqnum @nums, 1.0 ],
+               [ @nums ],
+               'uniqnum preserves uniqueness of full integer range' );
+
+    my @strs = map "$_", @nums;
+
+    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 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'
+    );
+}
+
+{
+    my $warnings = "";
+    local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
+
+    is_deeply( [ uniqnum 0, undef ],
+               [ 0 ],
+               'uniqnum considers undef and zero equivalent' );
+
+    ok( length $warnings, 'uniqnum on undef yields a warning' );
+
+    is_deeply( [ uniqnum undef ],
+               [ 0 ],
+               'uniqnum on undef coerces to zero' );
+}
+
+is_deeply( [uniqnum 0, -0.0 ],
+           [0],
+           'uniqnum handles negative zero');
+
+SKIP: {
+    skip ('test not relevant for this perl configuration', 4) unless $Config{ivsize} == 8;
+
+  # 1e17 is the number beyond which "%.20g" formatting fails on some
+  # 64-bit int perls.
+  # The following 2 tests check that the nearest values (both above
+  # and below that tipping point) are being handled correctly.
+
+  # 99999999999999984 is the largest 64-bit integer less than 1e17
+  # that can be expressed exactly as a double
+
+  is_deeply( [ uniqnum (99999999999999984, 99999999999999984.0) ],
+             [ (99999999999999984) ],
+             'uniqnum recognizes 99999999999999984 and 99999999999999984.0 as the same' );
+
+  is_deeply( [ uniqnum (-99999999999999984, -99999999999999984.0) ],
+             [ (-99999999999999984) ],
+             'uniqnum recognizes -99999999999999984 and -99999999999999984.0 as the same' );
+
+  # 100000000000000016 is the smallest positive 64-bit integer greater than 1e17
+  # that can be expressed exactly as a double
+
+  is_deeply( [ uniqnum (100000000000000016, 100000000000000016.0) ],
+             [ (100000000000000016) ],
+             'uniqnum recognizes 100000000000000016 and 100000000000000016.0 as the same' );
+
+  is_deeply( [ uniqnum (-100000000000000016, -100000000000000016.0) ],
+             [ (-100000000000000016) ],
+             'uniqnum recognizes -100000000000000016 and -100000000000000016.0 as the same' );
+}
+
+# uniqnum not confused by IV'ified floats
+SKIP: {
+    # This fails on 5.6 and isn't fixable without breaking a lot of other tests
+    skip 'This perl version gets confused by IVNV dualvars', 1 if $] lt '5.008000';
+    my @nums = ( 2.1, 2.2, 2.3 );
+    my $dummy = sprintf "%d", $_ for @nums;
+
+    # All @nums now have both NOK and IOK but IV=2 in each case
+    is( scalar( uniqnum @nums ), 3, 'uniqnum not confused by dual IV+NV' );
+}
+
+{
+    package Numify;
+
+    use overload '0+' => sub { return $_[0]->{num} };
+
+    sub new { bless { num => $_[1] }, $_[0] }
+
+    package main;
+    use Scalar::Util qw( refaddr );
+
+    my @nums = map { Numify->new( $_ ) } qw( 2 2 5 );
+
+    # is_deeply wants to use eq overloading
+    my @ret = uniqnum @nums;
+    ok( scalar @ret == 2 &&
+        refaddr $ret[0] == refaddr $nums[0] &&
+        refaddr $ret[1] == refaddr $nums[2],
+               'uniqnum respects numify overload' );
+}
+
+{
+    "1 1 2" =~ m/(.) (.) (.)/;
+    is_deeply( [ uniqnum $1, $2, $3 ],
+               [ 1, 2 ],
+               'uniqnum handles magic' );
+}
index 86ded97..39a4167 100644 (file)
@@ -7,8 +7,8 @@ use Config;
 
 use Scalar::Util ();
 use Test::More  ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE})
-                       ? (skip_all => 'weaken requires XS version')
-                       : (tests => 28);
+    ? (skip_all => 'weaken requires XS version')
+    : (tests => 28);
 
 Scalar::Util->import(qw(weaken unweaken isweak));
 
index 71daab7..2412234 100644 (file)
@@ -532,7 +532,7 @@ L<Safe> has been upgraded from version 2.40 to 2.41.
 
 =item *
 
-L<Scalar::Util> has been upgraded from version 1.50 to 1.53.
+L<Scalar::Util> has been upgraded from version 1.50 to 1.55.
 
 =item *