Index: ListUtil.xs =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs,v retrieving revision 1.2 diff -u -p -r1.2 ListUtil.xs --- ListUtil.xs 5 Feb 2017 00:32:03 -0000 1.2 +++ ListUtil.xs 25 Sep 2018 03:58:45 -0000 @@ -7,22 +7,76 @@ #include #include -#define NEED_sv_2pv_flags 1 -#include "ppport.h" +#ifdef USE_PPPORT_H +# define NEED_sv_2pv_flags 1 +# define NEED_newSVpvn_flags 1 +# define NEED_sv_catpvn_flags +# include "ppport.h" +#endif -#if PERL_BCDVERSION >= 0x5006000 +#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) +#endif +#ifndef PERL_VERSION_GE +# define PERL_VERSION_GE(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)) +#endif + +#if PERL_VERSION_GE(5,6,0) # include "multicall.h" #endif +#if !PERL_VERSION_GE(5,23,8) +# define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp) +#else +# define UNUSED_VAR_newsp NOOP +#endif + #ifndef CvISXSUB # define CvISXSUB(cv) CvXSUB(cv) #endif +#ifndef HvNAMELEN_get +#define HvNAMELEN_get(stash) strlen(HvNAME(stash)) +#endif + +#ifndef HvNAMEUTF8 +#define HvNAMEUTF8(stash) 0 +#endif + +#ifndef GvNAMEUTF8 +#ifdef GvNAME_HEK +#define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv)) +#else +#define GvNAMEUTF8(gv) 0 +#endif +#endif + +#ifndef SV_CATUTF8 +#define SV_CATUTF8 0 +#endif + +#ifndef SV_CATBYTES +#define SV_CATBYTES 0 +#endif + +#ifndef sv_catpvn_flags +#define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l) +#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 */ -#if PERL_BCDVERSION < 0x5007000 +#if !PERL_VERSION_GE(5,7,0) /* Not in 5.6.1. */ # ifdef cxinc # undef cxinc @@ -66,6 +120,10 @@ my_sv_copypv(pTHX_ SV *const dsv, SV *co # define croak_no_modify() croak("%s", PL_no_modify) #endif +#ifndef SvNV_nomg +# define SvNV_nomg SvNV +#endif + enum slu_accum { ACC_IV, ACC_NV, @@ -96,7 +154,7 @@ ALIAS: CODE: { int index; - NV retval; + NV retval = 0.0; /* avoid 'uninit var' warning */ SV *retsv; int magic; @@ -104,6 +162,7 @@ CODE: XSRETURN_UNDEF; retsv = ST(0); + SvGETMAGIC(retsv); magic = SvAMAGIC(retsv); if(!magic) retval = slu_sv_value(retsv); @@ -111,6 +170,7 @@ CODE: for(index = 1 ; index < items ; index++) { SV *stacksv = ST(index); SV *tmpsv; + SvGETMAGIC(stacksv); if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) { if(SvTRUE(tmpsv) ? !ix : ix) { retsv = stacksv; @@ -159,11 +219,12 @@ CODE: if(!items) switch(ix) { case 0: XSRETURN_UNDEF; - case 1: ST(0) = newSViv(0); XSRETURN(1); - case 2: ST(0) = newSViv(1); XSRETURN(1); + case 1: ST(0) = sv_2mortal(newSViv(0)); XSRETURN(1); + case 2: ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1); } sv = ST(0); + SvGETMAGIC(sv); switch((accum = accum_type(sv))) { case ACC_SV: retsv = TARG; @@ -179,6 +240,7 @@ CODE: for(index = 1 ; index < items ; index++) { sv = ST(index); + SvGETMAGIC(sv); if(accum < ACC_SV && SvAMAGIC(sv)){ if(!retsv) retsv = TARG; @@ -212,17 +274,72 @@ CODE: break; case ACC_IV: if(is_product) { - if(retiv == 0 || - (!SvNOK(sv) && SvIOK(sv) && (SvIV(sv) < IV_MAX / retiv))) { - retiv *= SvIV(sv); - break; + /* TODO: Consider if product() should shortcircuit the moment its + * accumulator becomes zero + */ + /* XXX testing flags before running get_magic may + * cause some valid tied values to fallback to the NV path + * - DAPM */ + if(!SvNOK(sv) && SvIOK(sv)) { + IV i = SvIV(sv); + if (retiv == 0) /* avoid later division by zero */ + break; + if (retiv < 0) { + if (i < 0) { + if (i >= IV_MAX / retiv) { + retiv *= i; + break; + } + } + else { + if (i <= IV_MIN / retiv) { + retiv *= i; + break; + } + } + } + else { + if (i < 0) { + if (i >= IV_MIN / retiv) { + retiv *= i; + break; + } + } + else { + if (i <= IV_MAX / retiv) { + retiv *= i; + break; + } + } + } } /* else fallthrough */ } else { - if(!SvNOK(sv) && SvIOK(sv) && (SvIV(sv) < IV_MAX - retiv)) { - retiv += SvIV(sv); - break; + /* XXX testing flags before running get_magic may + * cause some valid tied values to fallback to the NV path + * - DAPM */ + if(!SvNOK(sv) && SvIOK(sv)) { + IV i = SvIV(sv); + if (retiv >= 0 && i >= 0) { + if (retiv <= IV_MAX - i) { + retiv += i; + break; + } + /* else fallthrough */ + } + else if (retiv < 0 && i < 0) { + if (retiv >= IV_MIN - i) { + retiv += i; + break; + } + /* else fallthrough */ + } + else { + /* mixed signs can't overflow */ + retiv += i; + break; + } } /* else fallthrough */ } @@ -324,10 +441,12 @@ CODE: GvSV(agv) = ret; SvSetMagicSV(ret, args[1]); #ifdef dMULTICALL + assert(cv); if(!CvISXSUB(cv)) { dMULTICALL; I32 gimme = G_SCALAR; + UNUSED_VAR_newsp; PUSH_MULTICALL(cv); for(index = 2 ; index < items ; index++) { GvSV(bgv) = args[index]; @@ -378,13 +497,19 @@ CODE: SAVESPTR(GvSV(PL_defgv)); #ifdef dMULTICALL + assert(cv); if(!CvISXSUB(cv)) { dMULTICALL; I32 gimme = G_SCALAR; + + UNUSED_VAR_newsp; PUSH_MULTICALL(cv); for(index = 1 ; index < items ; index++) { - GvSV(PL_defgv) = args[index]; + SV *def_sv = GvSV(PL_defgv) = args[index]; +# ifdef SvTEMP_off + SvTEMP_off(def_sv); +# endif MULTICALL; if(SvTRUEx(*PL_stack_sp)) { # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT @@ -444,14 +569,19 @@ PPCODE: SAVESPTR(GvSV(PL_defgv)); #ifdef dMULTICALL + assert(cv); if(!CvISXSUB(cv)) { dMULTICALL; I32 gimme = G_SCALAR; int index; + UNUSED_VAR_newsp; PUSH_MULTICALL(cv); for(index = 1; index < items; index++) { - GvSV(PL_defgv) = args[index]; + SV *def_sv = GvSV(PL_defgv) = args[index]; +# ifdef SvTEMP_off + SvTEMP_off(def_sv); +# endif MULTICALL; if(SvTRUEx(*PL_stack_sp) ^ invert) { @@ -484,6 +614,56 @@ PPCODE: } void +head(size,...) +PROTOTYPE: $@ +ALIAS: + head = 0 + tail = 1 +PPCODE: +{ + int size = 0; + int start = 0; + int end = 0; + int i = 0; + + size = SvIV( ST(0) ); + + if ( ix == 0 ) { + start = 1; + end = start + size; + if ( size < 0 ) { + end += items - 1; + } + if ( end > items ) { + end = items; + } + } + else { + end = items; + if ( size < 0 ) { + start = -size + 1; + } + else { + start = end - size; + } + if ( start < 1 ) { + start = 1; + } + } + + if ( end < start ) { + XSRETURN(0); + } + else { + EXTEND( SP, end - start ); + for ( i = start; i <= end; i++ ) { + PUSHs( sv_2mortal( newSVsv( ST(i) ) ) ); + } + XSRETURN( end - start ); + } +} + +void pairs(...) PROTOTYPE: @ PPCODE: @@ -535,11 +715,11 @@ PPCODE: SvGETMAGIC(pair); if(SvTYPE(pair) != SVt_RV) - croak("Not a reference at List::Util::unpack() argument %d", i); + croak("Not a reference at List::Util::unpairs() argument %d", i); if(SvTYPE(SvRV(pair)) != SVt_PVAV) - croak("Not an ARRAY reference at List::Util::unpack() argument %d", i); + croak("Not an ARRAY reference at List::Util::unpairs() argument %d", i); - // TODO: assert pair is an ARRAY ref + /* TODO: assert pair is an ARRAY ref */ pairav = (AV *)SvRV(pair); EXTEND(SP, 2); @@ -622,6 +802,7 @@ PPCODE: SAVESPTR(GvSV(agv)); SAVESPTR(GvSV(bgv)); #ifdef dMULTICALL + assert(cv); if(!CvISXSUB(cv)) { /* Since MULTICALL is about to move it */ SV **stack = PL_stack_base + ax; @@ -629,6 +810,7 @@ PPCODE: dMULTICALL; I32 gimme = G_SCALAR; + UNUSED_VAR_newsp; PUSH_MULTICALL(cv); for(; argi < items; argi += 2) { SV *a = GvSV(agv) = stack[argi]; @@ -705,6 +887,7 @@ PPCODE: SAVESPTR(GvSV(agv)); SAVESPTR(GvSV(bgv)); #ifdef dMULTICALL + assert(cv); if(!CvISXSUB(cv)) { /* Since MULTICALL is about to move it */ SV **stack = PL_stack_base + ax; @@ -713,6 +896,7 @@ PPCODE: dMULTICALL; I32 gimme = G_SCALAR; + UNUSED_VAR_newsp; PUSH_MULTICALL(cv); for(; argi < items; argi += 2) { SV *a = GvSV(agv) = stack[argi]; @@ -793,67 +977,95 @@ PPCODE: /* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9 * Skip it on those versions (RT#87857) */ -#if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009) +#if defined(dMULTICALL) && (PERL_VERSION_GE(5,10,1) || PERL_VERSION_LE(5,8,8)) + assert(cv); if(!CvISXSUB(cv)) { /* Since MULTICALL is about to move it */ SV **stack = PL_stack_base + ax; I32 ret_gimme = GIMME_V; int i; + AV *spill = NULL; /* accumulates results if too big for stack */ dMULTICALL; I32 gimme = G_ARRAY; + UNUSED_VAR_newsp; PUSH_MULTICALL(cv); for(; argi < items; argi += 2) { - SV *a = GvSV(agv) = args_copy ? args_copy[argi] : stack[argi]; - SV *b = GvSV(bgv) = argi < items-1 ? - (args_copy ? args_copy[argi+1] : stack[argi+1]) : - &PL_sv_undef; int count; + GvSV(agv) = stack[argi]; + GvSV(bgv) = argi < items-1 ? stack[argi+1]: &PL_sv_undef; + MULTICALL; count = PL_stack_sp - PL_stack_base; - if(count > 2 && !args_copy) { + if (count > 2 || spill) { /* We can't return more than 2 results for a given input pair - * without trashing the remaining argmuents on the stack still - * to be processed. So, we'll copy them out to a temporary - * buffer and work from there instead. + * without trashing the remaining arguments on the stack still + * to be processed, or possibly overrunning the stack end. + * So, we'll accumulate the results in a temporary buffer + * instead. * We didn't do this initially because in the common case, most * code blocks will return only 1 or 2 items so it won't be * necessary */ - int n_args = items - argi; - Newx(args_copy, n_args, SV *); - SAVEFREEPV(args_copy); + int fill; - Copy(stack + argi, args_copy, n_args, SV *); + if (!spill) { + spill = newAV(); + AvREAL_off(spill); /* don't ref count its contents */ + /* can't mortalize here as every nextstate in the code + * block frees temps */ + SAVEFREESV(spill); + } - argi = 0; - items = n_args; + fill = (int)AvFILL(spill); + av_extend(spill, fill + count); + for(i = 0; i < count; i++) + (void)av_store(spill, ++fill, + newSVsv(PL_stack_base[i + 1])); } - - for(i = 0; i < count; i++) - stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]); + else + for(i = 0; i < count; i++) + stack[reti++] = newSVsv(PL_stack_base[i + 1]); } + + if (spill) + /* the POP_MULTICALL will trigger the SAVEFREESV above; + * keep it alive it on the temps stack instead */ + SvREFCNT_inc_simple_void_NN(spill); + sv_2mortal((SV*)spill); + POP_MULTICALL; + if (spill) { + int n = (int)AvFILL(spill) + 1; + SP = &ST(reti - 1); + EXTEND(SP, n); + for (i = 0; i < n; i++) + *++SP = *av_fetch(spill, i, FALSE); + reti += n; + av_clear(spill); + } + if(ret_gimme == G_ARRAY) for(i = 0; i < reti; i++) - sv_2mortal(stack[i]); + sv_2mortal(ST(i)); } else #endif { for(; argi < items; argi += 2) { dSP; - SV *a = GvSV(agv) = args_copy ? args_copy[argi] : ST(argi); - SV *b = GvSV(bgv) = argi < items-1 ? - (args_copy ? args_copy[argi+1] : ST(argi+1)) : - &PL_sv_undef; int count; int i; + GvSV(agv) = args_copy ? args_copy[argi] : ST(argi); + GvSV(bgv) = argi < items-1 ? + (args_copy ? args_copy[argi+1] : ST(argi+1)) : + &PL_sv_undef; + PUSHMARK(SP); count = call_sv((SV*)cv, G_ARRAY); @@ -927,6 +1139,120 @@ CODE: } +void +uniq(...) +PROTOTYPE: @ +ALIAS: + uniqnum = 0 + uniqstr = 1 + uniq = 2 +CODE: +{ + int retcount = 0; + int index; + SV **args = &PL_stack_base[ax]; + HV *seen; + + 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())); + + if(ix == 0) { + /* uniqnum */ + /* A temporary buffer for number stringification */ + SV *keysv = sv_newmortal(); + + for(index = 0 ; index < items ; index++) { + SV *arg = args[index]; +#ifdef HV_FETCH_EMPTY_HE + HE* he; +#endif + + 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)); + else + sv_setpvf(keysv, "%" 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; + + HeVAL(he) = &PL_sv_undef; +#else + if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv))) + continue; + + hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0); +#endif + + if(GIMME_V == G_ARRAY) + ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0)); + retcount++; + } + } + else { + /* uniqstr or uniq */ + int seen_undef = 0; + + for(index = 0 ; index < items ; index++) { + SV *arg = args[index]; +#ifdef HV_FETCH_EMPTY_HE + HE *he; +#endif + + 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; + + seen_undef++; + + if(GIMME_V == G_ARRAY) + ST(retcount) = arg; + retcount++; + continue; + } +#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; + + HeVAL(he) = &PL_sv_undef; +#else + if (hv_exists_ent(seen, arg, 0)) + continue; + + hv_store_ent(seen, arg, &PL_sv_yes, 0); +#endif + + 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)); +} + MODULE=List::Util PACKAGE=Scalar::Util void @@ -1040,7 +1366,10 @@ PROTOTYPE: $ INIT: SV *tsv; CODE: -#ifdef SvWEAKREF +#if defined(sv_rvunweaken) + PERL_UNUSED_VAR(tsv); + sv_rvunweaken(sv); +#elif defined(SvWEAKREF) /* This code stolen from core's sv_rvweaken() and modified */ if (!SvOK(sv)) return; @@ -1125,7 +1454,7 @@ CODE: if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) { sv = tempsv; } -#if PERL_BCDVERSION < 0x5008005 +#if !PERL_VERSION_GE(5,8,5) if(SvPOK(sv) || SvPOKp(sv)) { RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no; } @@ -1198,14 +1527,19 @@ PPCODE: void set_subname(name, sub) - char *name + SV *name SV *sub PREINIT: CV *cv = NULL; GV *gv; HV *stash = CopSTASH(PL_curcop); - char *s, *end = NULL; + const char *s, *end = NULL, *begin = NULL; MAGIC *mg; + STRLEN namelen; + const char* nameptr = SvPV(name, namelen); + int utf8flag = SvUTF8(name); + int quotes_seen = 0; + bool need_subst = FALSE; PPCODE: if (!SvROK(sub) && SvGMAGICAL(sub)) mg_get(sub); @@ -1218,63 +1552,77 @@ PPCODE: else if (PL_op->op_private & HINT_STRICT_REFS) croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", SvPV_nolen(sub), "a subroutine"); - else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV))) + else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV))) cv = GvCVu(gv); if (!cv) croak("Undefined subroutine %s", SvPV_nolen(sub)); if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) croak("Not a subroutine reference"); - for (s = name; *s++; ) { - if (*s == ':' && s[-1] == ':') - end = ++s; - else if (*s && s[-1] == '\'') - end = s; + for (s = nameptr; s <= nameptr + namelen; s++) { + if (s > nameptr && *s == ':' && s[-1] == ':') { + end = s - 1; + begin = ++s; + if (quotes_seen) + need_subst = TRUE; + } + else if (s > nameptr && *s != '\0' && s[-1] == '\'') { + end = s - 1; + begin = s; + if (quotes_seen++) + need_subst = TRUE; + } } s--; if (end) { - char *namepv = savepvn(name, end - name); - stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV)); - Safefree(namepv); - name = end; + SV* tmp; + if (need_subst) { + STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0); + char* left; + int i, j; + tmp = sv_2mortal(newSV(length)); + left = SvPVX(tmp); + for (i = 0, j = 0; j < end - nameptr; ++i, ++j) { + if (nameptr[j] == '\'') { + left[i] = ':'; + left[++i] = ':'; + } + else { + left[i] = nameptr[j]; + } + } + stash = gv_stashpvn(left, length, GV_ADD | utf8flag); + } + else + stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag); + nameptr = begin; + namelen -= begin - nameptr; } /* under debugger, provide information about sub location */ if (PL_DBsub && CvGV(cv)) { - HV *hv = GvHV(PL_DBsub); - - char *new_pkg = HvNAME(stash); - - char *old_name = GvNAME( CvGV(cv) ); - char *old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); - - int old_len = strlen(old_name) + strlen(old_pkg); - int new_len = strlen(name) + strlen(new_pkg); - - SV **old_data; - char *full_name; - - Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); - - strcat(full_name, old_pkg); - strcat(full_name, "::"); - strcat(full_name, old_name); - - old_data = hv_fetch(hv, full_name, strlen(full_name), 0); - - if (old_data) { - strcpy(full_name, new_pkg); - strcat(full_name, "::"); - strcat(full_name, name); + HV* DBsub = GvHV(PL_DBsub); + HE* old_data; - SvREFCNT_inc(*old_data); - if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0)) - SvREFCNT_dec(*old_data); + 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 (old_data && HeVAL(old_data)) { + SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); + sv_catpvn(new_full_name, "::", 2); + sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES); + SvREFCNT_inc(HeVAL(old_data)); + if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL) + SvREFCNT_inc(HeVAL(old_data)); } - Safefree(full_name); } gv = (GV *) newSV(0); - gv_init(gv, stash, name, s - name, TRUE); + gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag); /* * set_subname needs to create a GV to store the name. The CvGV field of a Index: Makefile.PL =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/Makefile.PL,v retrieving revision 1.1.1.1 diff -u -p -r1.1.1.1 Makefile.PL --- Makefile.PL 17 Nov 2014 20:52:58 -0000 1.1.1.1 +++ Makefile.PL 25 Sep 2018 03:58:45 -0000 @@ -11,7 +11,7 @@ WriteMakefile( NAME => q[List::Util], ABSTRACT => q[Common Scalar and List utility subroutines], AUTHOR => q[Graham Barr ], - DEFINE => q[-DPERL_EXT], + DEFINE => ($ENV{PERL_CORE} ? q[-DPERL_EXT] : q[-DPERL_EXT -DUSE_PPPORT_H]), DISTNAME => q[Scalar-List-Utils], VERSION_FROM => 'lib/List/Util.pm', @@ -28,13 +28,24 @@ WriteMakefile( ( $PERL_CORE ? () : ( - INSTALLDIRS => ($] < 5.011 ? q[perl] : q[site]), - PREREQ_PM => {'Test::More' => 0,}, + INSTALLDIRS => ($] < 5.011 ? q[perl] : q[site]), + PREREQ_PM => {'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) } ? ( META_MERGE => { + 'meta-spec' => { version => 2 }, + dynamic_config => 0, resources => { ## - repository => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils', + repository => { + url => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils.git', + web => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils', + type => 'git', + }, + bugtracker => { + mailto => 'bug-Scalar-List-Utils@rt.cpan.org', + web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-List-Utils', + }, }, } ) @@ -43,4 +54,3 @@ WriteMakefile( ) ), ); - Index: lib/List/Util.pm =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm,v retrieving revision 1.2 diff -u -p -r1.2 Util.pm --- lib/List/Util.pm 5 Feb 2017 00:32:03 -0000 1.2 +++ lib/List/Util.pm 25 Sep 2018 03:58:46 -0000 @@ -7,14 +7,15 @@ package List::Util; use strict; +use warnings; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw( - all any first min max minstr maxstr none notall product reduce sum sum0 shuffle - pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst + all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr + head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst ); -our $VERSION = "1.42_02"; +our $VERSION = "1.50"; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -38,17 +39,21 @@ sub import sub List::Util::_Pair::key { shift->[0] } sub List::Util::_Pair::value { shift->[1] } -1; - -__END__ - =head1 NAME List::Util - A selection of general-utility list subroutines =head1 SYNOPSIS - use List::Util qw(first max maxstr min minstr reduce shuffle sum); + use List::Util qw( + reduce any all none notall first + + max maxstr min minstr product sum sum0 + + pairs unpairs pairkeys pairvalues pairfirst pairgrep pairmap + + shuffle uniq uniqnum uniqstr + ); =head1 DESCRIPTION @@ -67,7 +72,9 @@ The following set of functions all reduc =cut -=head2 $result = reduce { BLOCK } @list +=head2 reduce + + $result = reduce { BLOCK } @list Reduces C<@list> by calling C in a scalar context multiple times, setting C<$a> and C<$b> each time. The first call will be with C<$a> and C<$b> @@ -107,6 +114,20 @@ C being returned $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value +The above example code blocks also suggest how to use C to build a +more efficient combined version of one of these basic functions and a C +block. For example, to find the total length of all the strings in a list, +we could use + + $total = sum map { length } @strings; + +However, this produces a list of temporary integer values as long as the +original list of strings, only to reduce it down to a single value again. We +can compute the same result more efficiently by using C with a code +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. @@ -128,6 +149,9 @@ instead, as it can short-circuit after t # at least one string has more than 10 characters } +Note: Due to XS issues the block passed may be able to access the outer @_ +directly. This is not intentional and will break under debugger. + =head2 all my $bool = all { BLOCK } @list; @@ -139,6 +163,9 @@ make the C return true. If any el false. If the C never returns false or the C<@list> was empty then it returns true. +Note: Due to XS issues the block passed may be able to access the outer @_ +directly. This is not intentional and will break under debugger. + =head2 none =head2 notall @@ -153,6 +180,9 @@ Similar to L and L, but with returns true only if no value in the C<@list> causes the C to return true, and C returns true only if not all of the values do. +Note: Due to XS issues the block passed may be able to access the outer @_ +directly. This is not intentional and will break under debugger. + =head2 first my $val = first { BLOCK } @list; @@ -289,22 +319,23 @@ Instead, write this using a lexical vari I A convenient shortcut to operating on even-sized lists of pairs, this function -returns a list of ARRAY references, each containing two items from the given -list. It is a more efficient version of +returns a list of C references, each containing two items from the +given list. It is a more efficient version of @pairs = pairmap { [ $a, $b ] } @kvlist It is most convenient to use in a C loop, for example: - foreach my $pair ( pairs @KVLIST ) { + foreach my $pair ( pairs @kvlist ) { my ( $key, $value ) = @$pair; ... } -Since version C<1.39> these ARRAY references are blessed objects, recognising -the two methods C and C. The following code is equivalent: +Since version C<1.39> these C references are blessed objects, +recognising the two methods C and C. The following code is +equivalent: - foreach my $pair ( pairs @KVLIST ) { + foreach my $pair ( pairs @kvlist ) { my $key = $pair->key; my $value = $pair->value; ... @@ -316,7 +347,7 @@ the two methods C and C. The I -The inverse function to C; this function takes a list of ARRAY +The inverse function to C; this function takes a list of C references containing two elements each, and returns a flattened list of the two values from each of the pairs, in order. This is notionally equivalent to @@ -454,8 +485,100 @@ Returns the values of the input in a ran @cards = shuffle 0..51 # 0..51 in a random order +=head2 uniq + + my @subset = uniq @values + +I + +Filters a list of values to remove subsequent duplicates, as judged by a +DWIM-ish string equality or C test. Preserves the order of unique +elements, and retains the first value of any duplicate set. + + my $count = uniq @values + +In scalar context, returns the number of elements that would have been +returned as a list. + +The C value is treated by this function as distinct from the empty +string, and no warning will be produced. It is left as-is in the returned +list. Subsequent C values are still considered identical to the first, +and will be removed. + +=head2 uniqnum + + my @subset = uniqnum @values + +I + +Filters a list of values to remove subsequent duplicates, as judged by a +numerical equality test. Preserves the order of unique elements, and retains +the first value of any duplicate set. + + my $count = uniqnum @values + +In scalar context, returns the number of elements that would have been +returned as a list. + +Note that C 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). In addition, an C in +the returned list is coerced into a numerical zero, so that the entire list of +values returned by C are well-behaved as numbers. + +Note also that multiple IEEE C values are treated as duplicates of +each other, regardless of any differences in their payloads, and despite +the fact that C<< 0+'NaN' == 0+'NaN' >> yields false. + +=head2 uniqstr + + my @subset = uniqstr @values + +I + +Filters a list of values to remove subsequent duplicates, as judged by a +string equality test. Preserves the order of unique elements, and retains the +first value of any duplicate set. + + my $count = uniqstr @values + +In scalar context, returns the number of elements that would have been +returned as a list. + +Note that C is treated much as other string operations treat it; it +compares equal to the empty string but additionally produces a warning if such +warnings are enabled (C). In addition, an +C in the returned list is coerced into an empty string, so that the +entire list of values returned by C are well-behaved as strings. + =cut +=head2 head + + my @values = head $size, @list; + +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>. + + @result = head 2, qw( foo bar baz ); + # foo, bar + + @result = head -2, qw( foo bar baz ); + # foo + +=head2 tail + + my @values = tail $size, @list; + +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>. + + @result = tail 2, qw( foo bar baz ); + # bar, baz + + @result = tail -2, qw( foo bar baz ); + # baz + =head1 KNOWN BUGS =head2 RT #95409 @@ -501,6 +624,21 @@ afterwards. Lexical variables that are o block's execution will take their individual values for each invocation, as normal. +=head2 uniqnum() on oversized bignums + +Due to the way that C compares numbers, it cannot distinguish +differences between bignums (especially bigints) that are too large to fit in +the native platform types. For example, + + my $x = Math::BigInt->new( "1" x 100 ); + my $y = $x + 1; + + say for uniqnum( $x, $y ); + +Will print just the value of C<$x>, believing that C<$y> is a numerically- +equivalent value. This bug does not affect C, which will correctly +observe that the two values stringify to different strings. + =head1 SUGGESTED ADDITIONS The following are additions that have been requested, but I have been reluctant @@ -528,3 +666,5 @@ Recent additions and current maintenance Paul Evans, . =cut + +1; Index: lib/List/Util/XS.pm =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm,v retrieving revision 1.2 diff -u -p -r1.2 XS.pm --- lib/List/Util/XS.pm 5 Feb 2017 00:32:03 -0000 1.2 +++ lib/List/Util/XS.pm 25 Sep 2018 03:58:46 -0000 @@ -1,8 +1,9 @@ package List::Util::XS; use strict; +use warnings; use List::Util; -our $VERSION = "1.42_02"; # FIXUP +our $VERSION = "1.50"; # FIXUP $VERSION = eval $VERSION; # FIXUP 1; Index: lib/Scalar/Util.pm =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm,v retrieving revision 1.2 diff -u -p -r1.2 Util.pm --- lib/Scalar/Util.pm 5 Feb 2017 00:32:03 -0000 1.2 +++ lib/Scalar/Util.pm 25 Sep 2018 03:58:46 -0000 @@ -7,6 +7,7 @@ package Scalar::Util; use strict; +use warnings; require Exporter; our @ISA = qw(Exporter); @@ -16,7 +17,7 @@ our @EXPORT_OK = qw( dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted ); -our $VERSION = "1.42_02"; +our $VERSION = "1.50"; $VERSION = eval $VERSION; require List::Util; # List::Util loads the XS @@ -74,8 +75,8 @@ Scalar::Util - A selection of general-ut C contains a selection of subroutines that people have expressed would be nice to have in the perl core, but the usage would not really be high -enough to warrant the use of a keyword, and the size so small such that being -individual extensions would be wasteful. +enough to warrant the use of a keyword, and the size would be so small that +being individual extensions would be wasteful. By default C does not export any subroutines. @@ -89,7 +90,7 @@ The following functions all perform some my $pkg = blessed( $ref ); -If C<$ref> is a blessed reference the name of the package that it is blessed +If C<$ref> is a blessed reference, the name of the package that it is blessed into is returned. Otherwise C is returned. $scalar = "foo"; @@ -108,7 +109,7 @@ C) because the pack my $addr = refaddr( $ref ); -If C<$ref> is reference the internal memory address of the referenced value is +If C<$ref> is reference, the internal memory address of the referenced value is returned as a plain integer. Otherwise C is returned. $addr = refaddr "string"; # undef @@ -122,7 +123,7 @@ returned as a plain integer. Otherwise C my $type = reftype( $ref ); -If C<$ref> is a reference the basic Perl type of the variable referenced is +If C<$ref> is a reference, the basic Perl type of the variable referenced is returned as a plain string (such as C or C). Otherwise C is returned. @@ -138,7 +139,7 @@ is returned. weaken( $ref ); The lvalue C<$ref> will be turned into a weak reference. This means that it -will not hold a reference count on the object it references. Also when the +will not hold a reference count on the object it references. Also, when the reference count on that object reaches zero, the reference will be set to undef. This function mutates the lvalue passed as its argument and returns no value. @@ -242,8 +243,8 @@ numeric operations: $bar = $foo + 0; $dual = isdual($foo); # true -Note that although C<$!> appears to be dual-valued variable, it is actually -implemented using a tied scalar: +Note that although C<$!> appears to be a dual-valued variable, it is +actually implemented as a magical variable inside the interpreter: $! = 1; print("$!\n"); # "Operation not permitted" @@ -258,7 +259,7 @@ You can capture its numeric and string c my $vstring = isvstring( $var ); -If C<$var> is a scalar which was coded as a vstring the result is true. +If C<$var> is a scalar which was coded as a vstring, the result is true. $vs = v49.46.48; $fmt = isvstring($vs) ? "%vd" : "%s"; #true @@ -327,15 +328,6 @@ use L or L you will ne The version of perl that you are using does not implement Vstrings, to use L you will need to use a newer release of perl. - -=item C is only available with the XS version of Scalar::Util - -C contains both perl and C implementations of many of its -functions so that those without access to a C compiler may still use it. -However some of the functions are only available when a C compiler was -available to compile the XS version of the extension. - -At present that list is: weaken, isweak, dualvar, isvstring, set_prototype =back Index: lib/Sub/Util.pm =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm,v retrieving revision 1.1 diff -u -p -r1.1 Util.pm --- lib/Sub/Util.pm 5 Feb 2017 00:32:03 -0000 1.1 +++ lib/Sub/Util.pm 25 Sep 2018 03:58:46 -0000 @@ -15,7 +15,7 @@ our @EXPORT_OK = qw( subname set_subname ); -our $VERSION = "1.42_02"; +our $VERSION = "1.50"; $VERSION = eval $VERSION; require List::Util; # as it has the XS @@ -102,7 +102,7 @@ This function was inspired by C implements can easily be emulated using regexp operations, such as - sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.+?)$/ } + sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.*?)$/ } sub sub_name { return (get_code_info $_[0])[0] } sub stash_name { return (get_code_info $_[0])[1] } Index: t/00version.t =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/00version.t,v retrieving revision 1.2 diff -u -p -r1.2 00version.t --- t/00version.t 5 Feb 2017 00:32:03 -0000 1.2 +++ t/00version.t 25 Sep 2018 03:58:46 -0000 @@ -6,10 +6,13 @@ use warnings; use Scalar::Util (); use List::Util (); use List::Util::XS (); -use Test::More tests => 2; +use Sub::Util (); +use Test::More tests => 4; -is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch"); +is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch between Scalar/List"); my $has_xs = eval { Scalar::Util->import('dualvar'); 1 }; my $xs_version = $has_xs ? $List::Util::VERSION : undef; -is( $List::Util::XS::VERSION, $xs_version, "XS VERSION"); +is( $List::Util::XS::VERSION, $xs_version, "VERSION mismatch between LU::XS and LU"); +is( $Sub::Util::VERSION, $Scalar::Util::VERSION, "VERSION mistmatch between Sub/Scalar"); +is( $Sub::Util::VERSION, $List::Util::VERSION, "VERSION mistmatch between Sub/List"); Index: t/exotic_names.t =================================================================== RCS file: t/exotic_names.t diff -N t/exotic_names.t --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ t/exotic_names.t 25 Sep 2018 03:58:46 -0000 @@ -0,0 +1,122 @@ +use strict; +use warnings; + +use Test::More; +use B 'svref_2object'; +BEGIN { $^P |= 0x210 } + +# This is a mess. The stash can supposedly handle Unicode but the behavior +# is literally undefined before 5.16 (with crashes beyond the basic plane), +# and remains unclear past 5.16 with evalbytes and feature unicode_eval +# In any case - Sub::Name needs to *somehow* work with this, so we will do +# a heuristic with ambiguous eval and looking for octets in the stash +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)"; +} + +sub compile_named_sub { + my ( $fullname, $body ) = @_; + my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}'; + return $sub if $sub; + my $e = $@; + require Carp; + Carp::croak $e; +} + +sub caller3_ok { + my ( $sub, $expected, $type, $ord ) = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + my $for_what = sprintf "when it contains \\x%s ( %s )", ( + ( ($ord > 255) + ? sprintf "{%X}", $ord + : sprintf "%02X", $ord + ), + ( + $ord > 255 ? unpack('H*', pack 'C0U', $ord ) + : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord + : sprintf '\%o', $ord + ), + ); + + $expected =~ s/'/::/g; + + # this is apparently how things worked before 5.16 + utf8::encode($expected) if $] < 5.016 and $ord > 255; + + my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV; + + is $stash_name, $expected, "stash name for $type is correct $for_what"; + is $sub->(), $expected, "caller() in $type returns correct name $for_what"; + SKIP: { + skip '%DB::sub not populated when enabled at runtime', 1 + unless keys %DB::sub; + my ($prefix) = $expected =~ /^(.*?test::[^:]+::)/; + my ($db_found) = grep /^$prefix/, keys %DB::sub; + is $db_found, $expected, "%DB::sub entry for $type is correct $for_what"; + } +} + +####################################################################### + +use Sub::Util 'set_subname'; + +my @ordinal = ( 1 .. 255 ); + +# 5.14 is the first perl to start properly handling \0 in identifiers +unshift @ordinal, 0 + unless $] < 5.014; + +# Unicode in 5.6 is not sane (crashes etc) +push @ordinal, + 0x100, # LATIN CAPITAL LETTER A WITH MACRON + 0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER + 0x2122, # TRADE MARK SIGN + 0x1f4a9, # PILE OF POO + unless $] < 5.008; + +plan tests => @ordinal * 2 * 3; + +my $legal_ident_char = "A-Z_a-z0-9'"; +$legal_ident_char .= join '', map chr, 0x100, 0x498 + unless $] < 5.008; + +my $uniq = 'A000'; +for my $ord (@ordinal) { + my $sub; + $uniq++; + my $pkg = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord; + my $subname = sprintf 'SOME_%s_%c_NAME', $uniq, $ord; + my $fullname = join '::', $pkg, $subname; + + $sub = set_subname $fullname => sub { (caller(0))[3] }; + caller3_ok $sub, $fullname, 'renamed closure', $ord; + + # test that we can *always* compile at least within the correct package + my $expected; + if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly + $expected = "native::$fullname"; + $sub = compile_named_sub $expected => '(caller(0))[3]'; + } + else { # not a legal identifier but at least test the package name by aliasing + $expected = "aliased::native::$fullname"; + { + no strict 'refs'; + *palatable:: = *{"aliased::native::${pkg}::"}; + # now palatable:: literally means aliased::native::${pkg}:: + my $encoded_sub = $subname; + utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255; + ${"palatable::$encoded_sub"} = 1; + ${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub}; + # and palatable::sub means aliased::native::${pkg}::${subname} + } + $sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]'; + } + caller3_ok $sub, $expected, 'natively compiled sub', $ord; +} Index: t/head-tail.t =================================================================== RCS file: t/head-tail.t diff -N t/head-tail.t --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ t/head-tail.t 25 Sep 2018 03:58:46 -0000 @@ -0,0 +1,97 @@ +#!./perl + +use strict; +use warnings; + +use List::Util qw(head tail); +use Test::More; +plan tests => 42; + +my @ary; + +ok(defined &head, 'defined'); +ok(defined &tail, 'defined'); + +@ary = head 1, ( 4, 5, 6 ); +is( scalar @ary, 1 ); +is( $ary[0], 4 ); + +@ary = head 2, ( 4, 5, 6 ); +is( scalar @ary, 2 ); +is( $ary[0], 4 ); +is( $ary[1], 5 ); + +@ary = head -1, ( 4, 5, 6 ); +is( scalar @ary, 2 ); +is( $ary[0], 4 ); +is( $ary[1], 5 ); + +@ary = head -2, ( 4, 5, 6 ); +is( scalar @ary, 1 ); +is( $ary[0], 4 ); + +@ary = head 999, ( 4, 5, 6 ); +is( scalar @ary, 3 ); +is( $ary[0], 4 ); +is( $ary[1], 5 ); +is( $ary[2], 6 ); + +@ary = head 0, ( 4, 5, 6 ); +is( scalar @ary, 0 ); + +@ary = head 0; +is( scalar @ary, 0 ); + +@ary = head 5; +is( scalar @ary, 0 ); + +@ary = head -3, ( 4, 5, 6 ); +is( scalar @ary, 0 ); + +@ary = head -999, ( 4, 5, 6 ); +is( scalar @ary, 0 ); + +eval '@ary = head'; +like( $@, qr{^Not enough arguments for List::Util::head} ); + +@ary = head 4, ( 4, 5, 6 ); +is( scalar @ary, 3 ); +is( $ary[0], 4 ); +is( $ary[1], 5 ); +is( $ary[2], 6 ); + +@ary = tail 1, ( 4, 5, 6 ); +is( scalar @ary, 1 ); +is( $ary[0], 6 ); + +@ary = tail 2, ( 4, 5, 6 ); +is( scalar @ary, 2 ); +is( $ary[0], 5 ); +is( $ary[1], 6 ); + +@ary = tail -1, ( 4, 5, 6 ); +is( scalar @ary, 2 ); +is( $ary[0], 5 ); +is( $ary[1], 6 ); + +@ary = tail -2, ( 4, 5, 6 ); +is( scalar @ary, 1 ); +is( $ary[0], 6 ); + +@ary = tail 0, ( 4, 5, 6 ); +is( scalar @ary, 0 ); + +@ary = tail 0; +is( scalar @ary, 0 ); + +@ary = tail 5; +is( scalar @ary, 0 ); + +@ary = tail -3; +is( scalar @ary, 0 ); + +@ary = tail -999; +is( scalar @ary, 0 ); + +eval '@ary = tail'; +like( $@, qr{^Not enough arguments for List::Util::tail} ); Index: t/min.t =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/min.t,v retrieving revision 1.2 diff -u -p -r1.2 min.t --- t/min.t 5 Feb 2017 00:32:03 -0000 1.2 +++ t/min.t 25 Sep 2018 03:58:46 -0000 @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 22; use List::Util qw(min); my $v; @@ -62,3 +62,21 @@ is($v, 1, 'bigint and normal int'); $v = min(1, 2, $v1, 3); is($v, 1, 'bigint and normal int'); +{ + # test that min/max and sum call GETMAGIC properly + # note, in my tests how this fails depends on exactly + # which List::Util subs are called and in what order. + my @list; + for my $size (10, 20, 10, 30) { + @list = ( 1 ) x $size; + + my $sum= List::Util::sum( 0, $#list ); + ok( $sum == $size-1, "sum(\$#list, 0) == $size-1"); + + my $min= List::Util::min( 15, $#list ); + ok( $min <= 15, "min(15,$size)" ); + + my $max= List::Util::max( 0, $#list ); + ok( $max == $size-1, "max(\$#list, 0) == $size-1"); + } +} Index: t/pair.t =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t,v retrieving revision 1.2 diff -u -p -r1.2 pair.t --- t/pair.t 5 Feb 2017 00:32:03 -0000 1.2 +++ t/pair.t 25 Sep 2018 03:58:46 -0000 @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 26; +use Test::More tests => 27; use List::Util qw(pairgrep pairfirst pairmap pairs unpairs pairkeys pairvalues); no warnings 'misc'; # avoid "Odd number of elements" warnings most of the time @@ -81,6 +81,16 @@ is_deeply( [ pairmap { $b } one => 1, tw is_deeply( [ pairmap { my @l = (1) x 1000; "$a=$b" } one => 1, two => 2, three => 3 ], [ "one=1", "two=2", "three=3" ], 'pairmap copes with stack movement' ); + +{ + # do the pairmap and is_deeply as two separate statements to avoid + # the stack being extended before pairmap is called + my @a = pairmap { $a .. $b } + 1 => 3, 4 => 4, 5 => 6, 7 => 1998, 1999 => 2000; + my @exp; push @exp, $_ for 1..2000; + is_deeply( \@a, \@exp, + 'pairmap result has more elements than input' ); +} is_deeply( [ pairs one => 1, two => 2, three => 3 ], [ [ one => 1 ], [ two => 2 ], [ three => 3 ] ], Index: t/product.t =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/product.t,v retrieving revision 1.2 diff -u -p -r1.2 product.t --- t/product.t 5 Feb 2017 00:32:03 -0000 1.2 +++ t/product.t 25 Sep 2018 03:58:46 -0000 @@ -3,8 +3,9 @@ use strict; use warnings; -use Test::More tests => 14; +use Test::More tests => 25; +use Config; use List::Util qw(product); my $v = product; @@ -22,6 +23,15 @@ is( $v, -1, 'one -1'); $v = product(0, 1, 2); is( $v, 0, 'first factor zero' ); +$v = product(0, 1); +is( $v, 0, '0 * 1'); + +$v = product(1, 0); +is( $v, 0, '1 * 0'); + +$v = product(0, 0); +is( $v, 0, 'two 0'); + my $x = -3; $v = product($x, 3); @@ -89,3 +99,30 @@ is($v, $v1 * 42 * 2, 'bigint + builtin i is($t, 567, 'overload returning non-overload'); } +SKIP: { + skip "IV is not at least 64bit", 8 unless $Config{ivsize} >= 8; + + my $t; + my $min = -(1<<31); + my $max = (1<<31)-1; + + $t = product($min, $min); + is($t, 1<<62, 'min * min'); + $t = product($min, $max); + is($t, (1<<31) - (1<<62), 'min * max'); + $t = product($max, $min); + is($t, (1<<31) - (1<<62), 'max * min'); + + $t = product($max, $max); + is($t, 4611686014132420609, 'max * max'); # (1<<62)-(1<<32)+1), but Perl 5.6 does not compute constant correctly + + $t = product($min*8, $min); + cmp_ok($t, '>', (1<<61), 'min*8*min'); # may be an NV + $t = product($min*8, $max); + cmp_ok($t, '<', -(1<<61), 'min*8*max'); # may be an NV + $t = product($max, $min*8); + cmp_ok($t, '<', -(1<<61), 'min*max*8'); # may be an NV + $t = product($max, $max*8); + cmp_ok($t, '>', (1<<61), 'max*max*8'); # may be an NV + +} Index: t/rt-96343.t =================================================================== RCS file: t/rt-96343.t diff -N t/rt-96343.t --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ t/rt-96343.t 25 Sep 2018 03:58:46 -0000 @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +{ + use List::Util qw( first ); + + my $hash = { + 'HellO WorlD' => 1, + }; + + is( ( first { 'hello world' eq lc($_) } keys %$hash ), "HellO WorlD", + 'first (lc$_) perserves value' ); +} + +{ + use List::Util qw( any ); + + my $hash = { + 'HellO WorlD' => 1, + }; + + my $var; + + no warnings 'void'; + any { lc($_); $var = $_; } keys %$hash; + + is( $var, 'HellO WorlD', + 'any (lc$_) leaves value undisturbed' ); +} Index: t/sum.t =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t,v retrieving revision 1.2 diff -u -p -r1.2 sum.t --- t/sum.t 5 Feb 2017 00:32:03 -0000 1.2 +++ t/sum.t 25 Sep 2018 03:58:46 -0000 @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 15; +use Test::More tests => 18; use Config; use List::Util qw(sum); @@ -91,9 +91,23 @@ is($v, $v1 + 42 + 2, 'bigint + builtin i } SKIP: { - skip "IV is not at least 64bit", 1 unless $Config{ivsize} >= 8; + skip "IV is not at least 64bit", 4 unless $Config{ivsize} >= 8; # Sum using NV will only preserve 53 bits of integer precision - my $t = sum(1<<60, 1); - cmp_ok($t, '>', 1<<60, 'sum uses IV where it can'); + my $t = sum(1152921504606846976, 1); # 1<<60, but Perl 5.6 does not compute constant correctly + cmp_ok($t, 'gt', 1152921504606846976, 'sum uses IV where it can'); # string comparison because Perl 5.6 does not compare it numerically correctly + + SKIP: { + skip "known to fail on $]", 1 if $] le "5.006002"; + $t = sum(1<<60, 1); + cmp_ok($t, '>', 1<<60, 'sum uses IV where it can'); + } + + my $min = -(1<<63); + my $max = 9223372036854775807; # (1<<63)-1, but Perl 5.6 does not compute constant correctly + + $t = sum($min, $max); + is($t, -1, 'min + max'); + $t = sum($max, $min); + is($t, -1, 'max + min'); } Index: t/tainted.t =================================================================== RCS file: /cvs/src/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t,v retrieving revision 1.2 diff -u -p -r1.2 tainted.t --- t/tainted.t 5 Feb 2017 00:32:03 -0000 1.2 +++ t/tainted.t 25 Sep 2018 03:58:46 -0000 @@ -13,12 +13,10 @@ my $var = 2; ok( !tainted($var), 'known variable'); -my $key = (grep { !/^PERL/ } keys %ENV)[0]; +ok( tainted($^X), 'interpreter variable'); -ok( tainted($ENV{$key}), 'environment variable'); - -$var = $ENV{$key}; -ok( tainted($var), 'copy of environment variable'); +$var = $^X; +ok( tainted($var), 'copy of interpreter variable'); { package Tainted; Index: t/uniq.t =================================================================== RCS file: t/uniq.t diff -N t/uniq.t --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ t/uniq.t 25 Sep 2018 03:58:46 -0000 @@ -0,0 +1,222 @@ +#!./perl + +use strict; +use warnings; + +use Test::More tests => 30; +use List::Util qw( uniqnum uniqstr uniq ); + +use Tie::Array; + +is_deeply( [ uniqstr ], + [], + 'uniqstr of empty list' ); + +is_deeply( [ uniqstr qw( abc ) ], + [qw( abc )], + 'uniqstr of singleton list' ); + +is_deeply( [ uniqstr qw( x x x ) ], + [qw( x )], + 'uniqstr of repeated-element list' ); + +is_deeply( [ uniqstr qw( a b a c ) ], + [qw( a b c )], + 'uniqstr removes subsequent duplicates' ); + +is_deeply( [ uniqstr qw( 1 1.0 1E0 ) ], + [qw( 1 1.0 1E0 )], + 'uniqstr compares strings' ); + +{ + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; + + is_deeply( [ uniqstr "", undef ], + [ "" ], + 'uniqstr considers undef and empty-string equivalent' ); + + ok( length $warnings, 'uniqstr on undef yields a warning' ); + + is_deeply( [ uniqstr undef ], + [ "" ], + 'uniqstr on undef coerces to empty-string' ); +} + +SKIP: { + skip 'Perl 5.007003 with utf8::encode is required', 3 if $] lt "5.007003"; + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; + + my $cafe = "cafe\x{301}"; + + is_deeply( [ uniqstr $cafe ], + [ $cafe ], + 'uniqstr is happy with Unicode strings' ); + + SKIP: { + skip "utf8::encode not available", 1 + unless defined &utf8::encode; + utf8::encode( my $cafebytes = $cafe ); + + is_deeply( [ uniqstr $cafe, $cafebytes ], + [ $cafe, $cafebytes ], + 'uniqstr does not squash bytewise-equal but differently-encoded strings' ); + } + + 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' ); + +# 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' ); + +{ + 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' ); +} + +{ + 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( [ uniq () ], + [], + 'uniq of empty list' ); + +{ + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; + + is_deeply( [ uniq "", undef ], + [ "", undef ], + 'uniq distintinguishes empty-string from undef' ); + + is_deeply( [ uniq undef, undef ], + [ undef ], + 'uniq considers duplicate undefs as identical' ); + + ok( !length $warnings, 'uniq on undef does not warn' ); +} + +is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' ); + +{ + package Stringify; + + use overload '""' => sub { return $_[0]->{str} }; + + sub new { bless { str => $_[1] }, $_[0] } + + package main; + + my @strs = map { Stringify->new( $_ ) } qw( foo foo bar ); + + is_deeply( [ map "$_", uniqstr @strs ], + [ map "$_", $strs[0], $strs[2] ], + 'uniqstr respects stringify overload' ); +} + +{ + 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' ); +} + +{ + package DestroyNotifier; + + use overload '""' => sub { "SAME" }; + + sub new { bless { var => $_[1] }, $_[0] } + + sub DESTROY { ${ $_[0]->{var} }++ } + + package main; + + my @destroyed = (0) x 3; + my @notifiers = map { DestroyNotifier->new( \$destroyed[$_] ) } 0 .. 2; + + my @uniqstr = uniqstr @notifiers; + undef @notifiers; + + is_deeply( \@destroyed, [ 0, 1, 1 ], + 'values filtered by uniqstr() are destroyed' ); + + undef @uniqstr; + is_deeply( \@destroyed, [ 1, 1, 1 ], + 'all values destroyed' ); +} + +{ + "a a b" =~ m/(.) (.) (.)/; + 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' ); +} + +{ + my @array; + tie @array, 'Tie::StdArray'; + @array = ( + ( map { ( 1 .. 10 ) } 0 .. 1 ), + ( map { ( 'a' .. 'z' ) } 0 .. 1 ) + ); + + my @u = uniq @array; + is_deeply( + \@u, + [ 1 .. 10, 'a' .. 'z' ], + 'uniq uniquifies mixed numbers and strings correctly in a tied array' + ); +}