diff options
Diffstat (limited to 'cpan/Scalar-List-Utils')
25 files changed, 1133 insertions, 318 deletions
diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs index b0d98b4470..5bccc88444 100644 --- a/cpan/Scalar-List-Utils/ListUtil.xs +++ b/cpan/Scalar-List-Utils/ListUtil.xs @@ -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> @@ -14,20 +15,35 @@ # 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) @@ -72,6 +88,12 @@ #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: diff --git a/cpan/Scalar-List-Utils/Makefile.PL b/cpan/Scalar-List-Utils/Makefile.PL index 37bd104b40..3dc13d769f 100644 --- a/cpan/Scalar-List-Utils/Makefile.PL +++ b/cpan/Scalar-List-Utils/Makefile.PL @@ -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); diff --git a/cpan/Scalar-List-Utils/lib/List/Util.pm b/cpan/Scalar-List-Utils/lib/List/Util.pm index e1b66c615e..e582d60874 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util.pm @@ -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 diff --git a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm index 4a7301ca8f..88f663f0ec 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm @@ -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; diff --git a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm index bf670c9cf4..a7345aad78 100644 --- a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm +++ b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm @@ -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 ); diff --git a/cpan/Scalar-List-Utils/lib/Sub/Util.pm b/cpan/Scalar-List-Utils/lib/Sub/Util.pm index 580bd8d136..d7b59aebab 100644 --- a/cpan/Scalar-List-Utils/lib/Sub/Util.pm +++ b/cpan/Scalar-List-Utils/lib/Sub/Util.pm @@ -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 diff --git a/cpan/Scalar-List-Utils/t/blessed.t b/cpan/Scalar-List-Utils/t/blessed.t index 2ae3679196..49eb355ffc 100644 --- a/cpan/Scalar-List-Utils/t/blessed.t +++ b/cpan/Scalar-List-Utils/t/blessed.t @@ -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 { diff --git a/cpan/Scalar-List-Utils/t/dualvar.t b/cpan/Scalar-List-Utils/t/dualvar.t index 08dff11778..bd77c969b5 100644 --- a/cpan/Scalar-List-Utils/t/dualvar.t +++ b/cpan/Scalar-List-Utils/t/dualvar.t @@ -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: { diff --git a/cpan/Scalar-List-Utils/t/exotic_names.t b/cpan/Scalar-List-Utils/t/exotic_names.t index cb5d2cc9f2..3c5f212325 100644 --- a/cpan/Scalar-List-Utils/t/exotic_names.t +++ b/cpan/Scalar-List-Utils/t/exotic_names.t @@ -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 { diff --git a/cpan/Scalar-List-Utils/t/first.t b/cpan/Scalar-List-Utils/t/first.t index ba7726ae56..3f008e703c 100644 --- a/cpan/Scalar-List-Utils/t/first.t +++ b/cpan/Scalar-List-Utils/t/first.t @@ -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; diff --git a/cpan/Scalar-List-Utils/t/isvstring.t b/cpan/Scalar-List-Utils/t/isvstring.t index 9d345aa26f..3649d41c59 100644 --- a/cpan/Scalar-List-Utils/t/isvstring.t +++ b/cpan/Scalar-List-Utils/t/isvstring.t @@ -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'); diff --git a/cpan/Scalar-List-Utils/t/lln.t b/cpan/Scalar-List-Utils/t/lln.t index df9ea3aea9..8458344671 100644 --- a/cpan/Scalar-List-Utils/t/lln.t +++ b/cpan/Scalar-List-Utils/t/lln.t @@ -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 diff --git a/cpan/Scalar-List-Utils/t/readonly.t b/cpan/Scalar-List-Utils/t/readonly.t index c8e19ff4c8..1333adeb4f 100644 --- a/cpan/Scalar-List-Utils/t/readonly.t +++ b/cpan/Scalar-List-Utils/t/readonly.t @@ -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 { diff --git a/cpan/Scalar-List-Utils/t/reduce.t b/cpan/Scalar-List-Utils/t/reduce.t index 848c34fb22..67fdbaac22 100644 --- a/cpan/Scalar-List-Utils/t/reduce.t +++ b/cpan/Scalar-List-Utils/t/reduce.t @@ -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 index 0000000000..fd669f14c7 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/reductions.t @@ -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' ); +} diff --git a/cpan/Scalar-List-Utils/t/refaddr.t b/cpan/Scalar-List-Utils/t/refaddr.t index 8d7c441bb3..91b6fa9ec6 100644 --- a/cpan/Scalar-List-Utils/t/refaddr.t +++ b/cpan/Scalar-List-Utils/t/refaddr.t @@ -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); } diff --git a/cpan/Scalar-List-Utils/t/reftype.t b/cpan/Scalar-List-Utils/t/reftype.t index a40e41493b..2fefd8fbef 100644 --- a/cpan/Scalar-List-Utils/t/reftype.t +++ b/cpan/Scalar-List-Utils/t/reftype.t @@ -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 index 0000000000..0927571948 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/sample.t @@ -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' + ); +} diff --git a/cpan/Scalar-List-Utils/t/scalarutil-proto.t b/cpan/Scalar-List-Utils/t/scalarutil-proto.t index e9b653a666..8d70a77cfd 100644 --- a/cpan/Scalar-List-Utils/t/scalarutil-proto.t +++ b/cpan/Scalar-List-Utils/t/scalarutil-proto.t @@ -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 diff --git a/cpan/Scalar-List-Utils/t/shuffle.t b/cpan/Scalar-List-Utils/t/shuffle.t index dff963715d..7135b5163c 100644 --- a/cpan/Scalar-List-Utils/t/shuffle.t +++ b/cpan/Scalar-List-Utils/t/shuffle.t @@ -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' + ); +} diff --git a/cpan/Scalar-List-Utils/t/sum.t b/cpan/Scalar-List-Utils/t/sum.t index e2c416df8c..5247a37b00 100644 --- a/cpan/Scalar-List-Utils/t/sum.t +++ b/cpan/Scalar-List-Utils/t/sum.t @@ -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'); diff --git a/cpan/Scalar-List-Utils/t/tainted.t b/cpan/Scalar-List-Utils/t/tainted.t index fb83c86c32..1197b29586 100644 --- a/cpan/Scalar-List-Utils/t/tainted.t +++ b/cpan/Scalar-List-Utils/t/tainted.t @@ -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; diff --git a/cpan/Scalar-List-Utils/t/uniq.t b/cpan/Scalar-List-Utils/t/uniq.t index 8e76f21b9b..c55f03a638 100644 --- a/cpan/Scalar-List-Utils/t/uniq.t +++ b/cpan/Scalar-List-Utils/t/uniq.t @@ -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 index 0000000000..d34d2c7747 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/uniqnum.t @@ -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' ); +} diff --git a/cpan/Scalar-List-Utils/t/weak.t b/cpan/Scalar-List-Utils/t/weak.t index 86ded9794f..39a4167cd6 100644 --- a/cpan/Scalar-List-Utils/t/weak.t +++ b/cpan/Scalar-List-Utils/t/weak.t @@ -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)); |