diff options
Diffstat (limited to 'gnu/usr.bin/perl/cpan/Scalar-List-Utils')
21 files changed, 714 insertions, 254 deletions
diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs index 12f98cde192..5bccc88444d 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs +++ b/gnu/usr.bin/perl/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 @@ -124,6 +146,38 @@ my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) # define SvNV_nomg SvNV #endif +#if PERL_VERSION_GE(5,16,0) +# define HAVE_UNICODE_PACKAGE_NAMES + +# ifndef sv_sethek +# define sv_sethek(a, b) Perl_sv_sethek(aTHX_ a, b) +# endif + +# ifndef sv_ref +# define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob) +static SV * +my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob) +{ + /* cargoculted from perl 5.22's sv.c */ + if(!dst) + dst = sv_newmortal(); + + if(ob && SvOBJECT(sv)) { + if(HvNAME_get(SvSTASH(sv))) + sv_sethek(dst, HvNAME_HEK(SvSTASH(sv))); + else + sv_setpvs(dst, "__ANON__"); + } + else { + const char *reftype = sv_reftype(sv, 0); + sv_setpv(dst, reftype); + } + + return dst; +} +# endif +#endif /* HAVE_UNICODE_PACKAGE_NAMES */ + enum slu_accum { ACC_IV, ACC_NV, @@ -143,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 @@ -344,9 +445,9 @@ CODE: /* else fallthrough */ } - /* fallthrough to NV now */ retnv = retiv; accum = ACC_NV; + /* FALLTHROUGH */ case ACC_NV: is_product ? (retnv *= slu_sv_value(sv)) : (retnv += slu_sv_value(sv)); @@ -419,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]; @@ -431,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); @@ -440,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)) { @@ -452,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) @@ -470,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 @@ -1105,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; @@ -1138,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: @@ -1152,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 @@ -1162,88 +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(SvUOK(arg)) - sv_setpvf(keysv, "%" UVuf, SvUV(arg)); - else if(SvIOK(arg)) - sv_setpvf(keysv, "%" IVdf, SvIV(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 + /* int_amg only appeared in perl 5.8.0 */ + if(SvAMAGIC(arg) && (arg = AMG_CALLun(arg, int))) + ; /* nothing to do */ else - sv_setpvf(keysv, "%" NVgf, SvNV(arg)); +#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); + } + } #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++; + } + + 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; } - else { - /* uniqstr or uniq */ - int seen_undef = 0; - for(index = 0 ; index < items ; index++) { - SV *arg = args[index]; + 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: @@ -1302,7 +1614,7 @@ CODE: ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv))); XSRETURN(1); -char * +SV * blessed(sv) SV *sv PROTOTYPE: $ @@ -1312,8 +1624,12 @@ CODE: if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) XSRETURN_UNDEF; - - RETVAL = (char*)sv_reftype(SvRV(sv),TRUE); +#ifdef HAVE_UNICODE_PACKAGE_NAMES + RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE)); +#else + RETVAL = newSV(0); + sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE)); +#endif } OUTPUT: RETVAL @@ -1601,15 +1917,18 @@ PPCODE: /* under debugger, provide information about sub location */ if (PL_DBsub && CvGV(cv)) { HV* DBsub = GvHV(PL_DBsub); - HE* old_data; + HE* old_data = NULL; GV* oldgv = CvGV(cv); HV* oldhv = GvSTASH(oldgv); - SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0)); - sv_catpvn(old_full_name, "::", 2); - sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); - old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); + if (oldhv) { + SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0)); + sv_catpvn(old_full_name, "::", 2); + sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); + + old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); + } if (old_data && HeVAL(old_data)) { SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); @@ -1660,6 +1979,7 @@ subname(code) PREINIT: CV *cv; GV *gv; + const char *stashname; PPCODE: if (!SvROK(code) && SvGMAGICAL(code)) mg_get(code); @@ -1670,7 +1990,12 @@ PPCODE: if(!(gv = CvGV(cv))) XSRETURN(0); - mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv))); + if(GvSTASH(gv)) + stashname = HvNAME(GvSTASH(gv)); + else + stashname = "__ANON__"; + + mPUSHs(newSVpvf("%s::%s", stashname, GvNAME(gv))); XSRETURN(1); BOOT: diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm index b650d3585ac..e582d608743 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm +++ b/gnu/usr.bin/perl/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.50"; +our $VERSION = "1.55"; our $XS_VERSION = $VERSION; -$VERSION = eval $VERSION; +$VERSION =~ tr/_//d; require XSLoader; XSLoader::load('List::Util', $XS_VERSION); +# Used by shuffle() +our $RAND; + sub import { my $pkg = caller; @@ -38,6 +42,7 @@ sub import # For objects returned by pairs() sub List::Util::_Pair::key { shift->[0] } sub List::Util::_Pair::value { shift->[1] } +sub List::Util::_Pair::TO_JSON { [ @{+shift} ] } =head1 NAME @@ -46,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 @@ -68,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 @@ -128,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 @@ -341,6 +367,9 @@ equivalent: ... } +Since version C<1.51> they also have a C<TO_JSON> method to ease +serialisation. + =head2 unpairs my @kvlist = unpairs @pairs @@ -485,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 @@ -505,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 @@ -557,6 +627,8 @@ entire list of values returned by C<uniqstr> are well-behaved as strings. my @values = head $size, @list; +I<Since version 1.50.> + Returns the first C<$size> elements from C<@list>. If C<$size> is negative, returns all but the last C<$size> elements from C<@list>. @@ -570,6 +642,8 @@ all but the last C<$size> elements from C<@list>. my @values = tail $size, @list; +I<Since version 1.50.> + Returns the last C<$size> elements from C<@list>. If C<$size> is negative, returns all but the first C<$size> elements from C<@list>. @@ -579,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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm index c8c066f8256..88f663f0ec4 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm @@ -3,8 +3,8 @@ use strict; use warnings; use List::Util; -our $VERSION = "1.50"; # FIXUP -$VERSION = eval $VERSION; # FIXUP +our $VERSION = "1.55"; # FIXUP +$VERSION =~ tr/_//d; # FIXUP 1; __END__ diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm index 69821587059..a7345aad78a 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm @@ -17,8 +17,8 @@ our @EXPORT_OK = qw( dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted ); -our $VERSION = "1.50"; -$VERSION = eval $VERSION; +our $VERSION = "1.55"; +$VERSION =~ tr/_//d; require List::Util; # List::Util loads the XS List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863) @@ -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 ); @@ -276,8 +281,8 @@ L<perlapi/looks_like_number>. my $fh = openhandle( $fh ); -Returns C<$fh> itself if C<$fh> may be used as a filehandle and is open, or is -is a tied handle. Otherwise C<undef> is returned. +Returns C<$fh> itself, if C<$fh> may be used as a filehandle and is open, or if +it is a tied handle. Otherwise C<undef> is returned. $fh = openhandle(*STDIN); # \*STDIN $fh = openhandle(\*STDIN); # \*STDIN diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm index edcc6544f6e..d7b59aebab8 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm @@ -15,8 +15,8 @@ our @EXPORT_OK = qw( subname set_subname ); -our $VERSION = "1.50"; -$VERSION = eval $VERSION; +our $VERSION = "1.55"; +$VERSION =~ tr/_//d; require List::Util; # as it has the XS List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863) @@ -95,8 +95,10 @@ I<Since version 1.40.> Returns the name of the given C<$code> reference, if it has one. Normal named subs will give a fully-qualified name consisting of the package and the localname separated by C<::>. Anonymous code references will give C<__ANON__> -as the localname. If a name has been set using L</set_subname>, this name will -be returned instead. +as the localname. If the package the code was compiled in has been deleted +(e.g. using C<delete_package> from L<Symbol>), C<__ANON__> will be returned as +the package name. If a name has been set using L</set_subname>, this name will be +returned instead. This function was inspired by C<sub_fullname> from L<Sub::Identify>. The remaining functions that C<Sub::Identify> implements can easily be emulated diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t index 21d3a9ade49..49eb355ffc5 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t @@ -3,28 +3,28 @@ use strict; use warnings; -use Test::More tests => 11; +use Test::More tests => 12; 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 { @@ -46,3 +46,11 @@ cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref'); ::is( ::blessed($obj), __PACKAGE__, "blessed on broken isa() and can()" ); } +SKIP: { + # Unicode package names only supported in perl 5.16 onwards + skip "Unicode package names are not supported", 1 if $] < 5.016; + + my $utf8_pack= "X\x{100}"; + my $obj= bless {}, $utf8_pack; + ::is( ::blessed($obj), $utf8_pack, "blessed preserves utf8ness for utf8 class names" ); +} diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/dualvar.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/dualvar.t index 08dff11778e..bd77c969b5a 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/dualvar.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/first.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/first.t index ba7726ae562..3f008e703c0 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/first.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/isvstring.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/isvstring.t index 9d345aa26fa..3649d41c59f 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/isvstring.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/lln.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/lln.t index df9ea3aea93..84583446716 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/lln.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t index e65123cc2c7..7d7a6a9bb59 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t @@ -3,8 +3,9 @@ use strict; use warnings; -use Test::More tests => 27; +use Test::More tests => 29; use List::Util qw(pairgrep pairfirst pairmap pairs unpairs pairkeys pairvalues); +use Scalar::Util qw(blessed); no warnings 'misc'; # avoid "Odd number of elements" warnings most of the time @@ -104,6 +105,10 @@ is_deeply( [ pairs one => 1, two => ], my @p = pairs one => 1, two => 2; is( $p[0]->key, "one", 'pairs ->key' ); is( $p[0]->value, 1, 'pairs ->value' ); + is_deeply( $p[0]->TO_JSON, + [ one => 1 ], + 'pairs ->TO_JSON' ); + ok( !blessed($p[0]->TO_JSON) , 'pairs ->TO_JSON is not blessed' ); } is_deeply( [ unpairs [ four => 4 ], [ five => 5 ], [ six => 6 ] ], diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/readonly.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/readonly.t index c8e19ff4c85..1333adeb4fc 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/readonly.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reduce.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reduce.t index 848c34fb221..67fdbaac228 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reduce.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/refaddr.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/refaddr.t index 8d7c441bb32..91b6fa9ec68 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/refaddr.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reftype.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reftype.t index a40e41493b5..2fefd8fbef0 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reftype.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/scalarutil-proto.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/scalarutil-proto.t index e9b653a6667..8d70a77cfd7 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/scalarutil-proto.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/shuffle.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/shuffle.t index dff963715dc..7135b5163ce 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/shuffle.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t index 1bf8a9f698e..c78a70043f6 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t @@ -3,10 +3,11 @@ use warnings; BEGIN { $^P |= 0x210 } -use Test::More tests => 18; +use Test::More tests => 21; use B::Deparse; use Sub::Util qw( subname set_subname ); +use Symbol qw( delete_package ) ; { sub localfunc {} @@ -78,4 +79,18 @@ is($x->(), "main::foo"); 'subname of set_subname'); } +# this used to segfault + +{ + sub ToDelete::foo {} + + my $foo = \&ToDelete::foo; + + delete_package 'ToDelete'; + + is( subname($foo), "$]" >= 5.010 ? '__ANON__::foo' : 'ToDelete::foo', 'subname in deleted package' ); + ok( set_subname('NewPackage::foo', $foo), 'rename from deleted package' ); + is( subname($foo), 'NewPackage::foo', 'subname after rename' ); +} + # vim: ft=perl diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t index e2c416df8c0..5247a37b004 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t index fb83c86c327..1197b295869 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t +++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/weak.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/weak.t index 86ded9794fc..39a4167cd6a 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/weak.t +++ b/gnu/usr.bin/perl/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)); |