diff options
Diffstat (limited to 'cpan/Scalar-List-Utils')
33 files changed, 3931 insertions, 0 deletions
diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs new file mode 100644 index 0000000000..96c6d2b055 --- /dev/null +++ b/cpan/Scalar-List-Utils/ListUtil.xs @@ -0,0 +1,1077 @@ +/* Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + */ +#define PERL_NO_GET_CONTEXT /* we want efficiency */ +#include <EXTERN.h> +#include <perl.h> +#include <XSUB.h> + +#define NEED_sv_2pv_flags 1 +#include "ppport.h" + +#if PERL_BCDVERSION >= 0x5006000 +# include "multicall.h" +#endif + +#ifndef CvISXSUB +# define CvISXSUB(cv) CvXSUB(cv) +#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 +/* Not in 5.6.1. */ +# ifdef cxinc +# undef cxinc +# endif +# define cxinc() my_cxinc(aTHX) +static I32 +my_cxinc(pTHX) +{ + cxstack_max = cxstack_max * 3 / 2; + Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */ + return cxstack_ix + 1; +} +#endif + +#ifndef sv_copypv +#define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b) +static void +my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) +{ + STRLEN len; + const char * const s = SvPV_const(ssv,len); + sv_setpvn(dsv,s,len); + if(SvUTF8(ssv)) + SvUTF8_on(dsv); + else + SvUTF8_off(dsv); +} +#endif + +#ifdef SVf_IVisUV +# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv)) +#else +# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv)) +#endif + +#if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9) +# define PERL_HAS_BAD_MULTICALL_REFCOUNT +#endif + +MODULE=List::Util PACKAGE=List::Util + +void +min(...) +PROTOTYPE: @ +ALIAS: + min = 0 + max = 1 +CODE: +{ + int index; + NV retval; + SV *retsv; + int magic; + + if(!items) + XSRETURN_UNDEF; + + retsv = ST(0); + magic = SvAMAGIC(retsv); + if(!magic) + retval = slu_sv_value(retsv); + + for(index = 1 ; index < items ; index++) { + SV *stacksv = ST(index); + SV *tmpsv; + if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) { + if(SvTRUE(tmpsv) ? !ix : ix) { + retsv = stacksv; + magic = SvAMAGIC(retsv); + if(!magic) { + retval = slu_sv_value(retsv); + } + } + } + else { + NV val = slu_sv_value(stacksv); + if(magic) { + retval = slu_sv_value(retsv); + magic = 0; + } + if(val < retval ? !ix : ix) { + retsv = stacksv; + retval = val; + } + } + } + ST(0) = retsv; + XSRETURN(1); +} + + +void +sum(...) +PROTOTYPE: @ +ALIAS: + sum = 0 + sum0 = 1 + product = 2 +CODE: +{ + dXSTARG; + SV *sv; + SV *retsv = NULL; + int index; + NV retval = 0; + int magic; + int is_product = (ix == 2); + + if(!items) + switch(ix) { + case 0: XSRETURN_UNDEF; + case 1: ST(0) = newSViv(0); XSRETURN(1); + case 2: ST(0) = newSViv(1); XSRETURN(1); + } + + sv = ST(0); + magic = SvAMAGIC(sv); + if(magic) { + retsv = TARG; + sv_setsv(retsv, sv); + } + else { + retval = slu_sv_value(sv); + } + + for(index = 1 ; index < items ; index++) { + sv = ST(index); + if(!magic && SvAMAGIC(sv)){ + magic = TRUE; + if(!retsv) + retsv = TARG; + sv_setnv(retsv,retval); + } + if(magic) { + SV *const tmpsv = amagic_call(retsv, sv, + is_product ? mult_amg : add_amg, + SvAMAGIC(retsv) ? AMGf_assign : 0); + if(tmpsv) { + magic = SvAMAGIC(tmpsv); + if(!magic) { + retval = slu_sv_value(tmpsv); + } + else { + retsv = tmpsv; + } + } + else { + /* fall back to default */ + magic = FALSE; + is_product ? (retval = SvNV(retsv) * SvNV(sv)) + : (retval = SvNV(retsv) + SvNV(sv)); + } + } + else { + is_product ? (retval *= slu_sv_value(sv)) + : (retval += slu_sv_value(sv)); + } + } + if(!magic) { + if(!retsv) + retsv = TARG; + sv_setnv(retsv,retval); + } + + ST(0) = retsv; + XSRETURN(1); +} + +#define SLU_CMP_LARGER 1 +#define SLU_CMP_SMALLER -1 + +void +minstr(...) +PROTOTYPE: @ +ALIAS: + minstr = SLU_CMP_LARGER + maxstr = SLU_CMP_SMALLER +CODE: +{ + SV *left; + int index; + + if(!items) + XSRETURN_UNDEF; + + left = ST(0); +#ifdef OPpLOCALE + if(MAXARG & OPpLOCALE) { + for(index = 1 ; index < items ; index++) { + SV *right = ST(index); + if(sv_cmp_locale(left, right) == ix) + left = right; + } + } + else { +#endif + for(index = 1 ; index < items ; index++) { + SV *right = ST(index); + if(sv_cmp(left, right) == ix) + left = right; + } +#ifdef OPpLOCALE + } +#endif + ST(0) = left; + XSRETURN(1); +} + + + + +void +reduce(block,...) + SV *block +PROTOTYPE: &@ +CODE: +{ + SV *ret = sv_newmortal(); + int index; + GV *agv,*bgv,*gv; + HV *stash; + SV **args = &PL_stack_base[ax]; + CV *cv = sv_2cv(block, &stash, &gv, 0); + + if(cv == Nullcv) + croak("Not a subroutine reference"); + + if(items <= 1) + XSRETURN_UNDEF; + + agv = gv_fetchpv("a", GV_ADD, SVt_PV); + bgv = gv_fetchpv("b", GV_ADD, SVt_PV); + SAVESPTR(GvSV(agv)); + SAVESPTR(GvSV(bgv)); + GvSV(agv) = ret; + SvSetSV(ret, args[1]); +#ifdef dMULTICALL + if(!CvISXSUB(cv)) { + dMULTICALL; + I32 gimme = G_SCALAR; + + PUSH_MULTICALL(cv); + for(index = 2 ; index < items ; index++) { + GvSV(bgv) = args[index]; + MULTICALL; + SvSetSV(ret, *PL_stack_sp); + } +# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT + if(CvDEPTH(multicall_cv) > 1) + SvREFCNT_inc_simple_void_NN(multicall_cv); +# endif + POP_MULTICALL; + } + else +#endif + { + for(index = 2 ; index < items ; index++) { + dSP; + GvSV(bgv) = args[index]; + + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + + SvSetSV(ret, *PL_stack_sp); + } + } + + ST(0) = ret; + XSRETURN(1); +} + +void +first(block,...) + SV *block +PROTOTYPE: &@ +CODE: +{ + int index; + GV *gv; + HV *stash; + SV **args = &PL_stack_base[ax]; + CV *cv = sv_2cv(block, &stash, &gv, 0); + + if(cv == Nullcv) + croak("Not a subroutine reference"); + + if(items <= 1) + XSRETURN_UNDEF; + + SAVESPTR(GvSV(PL_defgv)); +#ifdef dMULTICALL + if(!CvISXSUB(cv)) { + dMULTICALL; + I32 gimme = G_SCALAR; + PUSH_MULTICALL(cv); + + for(index = 1 ; index < items ; index++) { + GvSV(PL_defgv) = args[index]; + MULTICALL; + if(SvTRUEx(*PL_stack_sp)) { +# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT + if(CvDEPTH(multicall_cv) > 1) + SvREFCNT_inc_simple_void_NN(multicall_cv); +# endif + POP_MULTICALL; + ST(0) = ST(index); + XSRETURN(1); + } + } +# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT + if(CvDEPTH(multicall_cv) > 1) + SvREFCNT_inc_simple_void_NN(multicall_cv); +# endif + POP_MULTICALL; + } + else +#endif + { + for(index = 1 ; index < items ; index++) { + dSP; + GvSV(PL_defgv) = args[index]; + + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + if(SvTRUEx(*PL_stack_sp)) { + ST(0) = ST(index); + XSRETURN(1); + } + } + } + XSRETURN_UNDEF; +} + + +void +any(block,...) + SV *block +ALIAS: + none = 0 + all = 1 + any = 2 + notall = 3 +PROTOTYPE: &@ +PPCODE: +{ + int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */ + int invert = (ix & 1); /* invert block test for all/notall */ + GV *gv; + HV *stash; + SV **args = &PL_stack_base[ax]; + CV *cv = sv_2cv(block, &stash, &gv, 0); + + if(cv == Nullcv) + croak("Not a subroutine reference"); + + SAVESPTR(GvSV(PL_defgv)); +#ifdef dMULTICALL + if(!CvISXSUB(cv)) { + dMULTICALL; + I32 gimme = G_SCALAR; + int index; + + PUSH_MULTICALL(cv); + for(index = 1; index < items; index++) { + GvSV(PL_defgv) = args[index]; + + MULTICALL; + if(SvTRUEx(*PL_stack_sp) ^ invert) { + POP_MULTICALL; + ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes; + XSRETURN(1); + } + } + POP_MULTICALL; + } + else +#endif + { + int index; + for(index = 1; index < items; index++) { + dSP; + GvSV(PL_defgv) = args[index]; + + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + if(SvTRUEx(*PL_stack_sp) ^ invert) { + ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes; + XSRETURN(1); + } + } + } + + ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no; + XSRETURN(1); +} + +void +pairfirst(block,...) + SV *block +PROTOTYPE: &@ +PPCODE: +{ + GV *agv,*bgv,*gv; + HV *stash; + CV *cv = sv_2cv(block, &stash, &gv, 0); + I32 ret_gimme = GIMME_V; + int argi = 1; /* "shift" the block */ + + if(!(items % 2) && ckWARN(WARN_MISC)) + warn("Odd number of elements in pairfirst"); + + agv = gv_fetchpv("a", GV_ADD, SVt_PV); + bgv = gv_fetchpv("b", GV_ADD, SVt_PV); + SAVESPTR(GvSV(agv)); + SAVESPTR(GvSV(bgv)); +#ifdef dMULTICALL + if(!CvISXSUB(cv)) { + /* Since MULTICALL is about to move it */ + SV **stack = PL_stack_base + ax; + + dMULTICALL; + I32 gimme = G_SCALAR; + + PUSH_MULTICALL(cv); + for(; argi < items; argi += 2) { + SV *a = GvSV(agv) = stack[argi]; + SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef; + + MULTICALL; + + if(!SvTRUEx(*PL_stack_sp)) + continue; + + POP_MULTICALL; + if(ret_gimme == G_ARRAY) { + ST(0) = sv_mortalcopy(a); + ST(1) = sv_mortalcopy(b); + XSRETURN(2); + } + else + XSRETURN_YES; + } + POP_MULTICALL; + XSRETURN(0); + } + else +#endif + { + for(; argi < items; argi += 2) { + dSP; + SV *a = GvSV(agv) = ST(argi); + SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef; + + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + + SPAGAIN; + + if(!SvTRUEx(*PL_stack_sp)) + continue; + + if(ret_gimme == G_ARRAY) { + ST(0) = sv_mortalcopy(a); + ST(1) = sv_mortalcopy(b); + XSRETURN(2); + } + else + XSRETURN_YES; + } + } + + XSRETURN(0); +} + +void +pairgrep(block,...) + SV *block +PROTOTYPE: &@ +PPCODE: +{ + GV *agv,*bgv,*gv; + HV *stash; + CV *cv = sv_2cv(block, &stash, &gv, 0); + I32 ret_gimme = GIMME_V; + + /* This function never returns more than it consumed in arguments. So we + * can build the results "live", behind the arguments + */ + int argi = 1; /* "shift" the block */ + int reti = 0; + + if(!(items % 2) && ckWARN(WARN_MISC)) + warn("Odd number of elements in pairgrep"); + + agv = gv_fetchpv("a", GV_ADD, SVt_PV); + bgv = gv_fetchpv("b", GV_ADD, SVt_PV); + SAVESPTR(GvSV(agv)); + SAVESPTR(GvSV(bgv)); +#ifdef dMULTICALL + if(!CvISXSUB(cv)) { + /* Since MULTICALL is about to move it */ + SV **stack = PL_stack_base + ax; + int i; + + dMULTICALL; + I32 gimme = G_SCALAR; + + PUSH_MULTICALL(cv); + for(; argi < items; argi += 2) { + SV *a = GvSV(agv) = stack[argi]; + SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef; + + MULTICALL; + + if(SvTRUEx(*PL_stack_sp)) { + if(ret_gimme == G_ARRAY) { + /* We can't mortalise yet or they'd be mortal too early */ + stack[reti++] = newSVsv(a); + stack[reti++] = newSVsv(b); + } + else if(ret_gimme == G_SCALAR) + reti++; + } + } + POP_MULTICALL; + + if(ret_gimme == G_ARRAY) + for(i = 0; i < reti; i++) + sv_2mortal(stack[i]); + } + else +#endif + { + for(; argi < items; argi += 2) { + dSP; + SV *a = GvSV(agv) = ST(argi); + SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef; + + PUSHMARK(SP); + call_sv((SV*)cv, G_SCALAR); + + SPAGAIN; + + if(SvTRUEx(*PL_stack_sp)) { + if(ret_gimme == G_ARRAY) { + ST(reti++) = sv_mortalcopy(a); + ST(reti++) = sv_mortalcopy(b); + } + else if(ret_gimme == G_SCALAR) + reti++; + } + } + } + + if(ret_gimme == G_ARRAY) + XSRETURN(reti); + else if(ret_gimme == G_SCALAR) { + ST(0) = newSViv(reti); + XSRETURN(1); + } +} + +void +pairmap(block,...) + SV *block +PROTOTYPE: &@ +PPCODE: +{ + GV *agv,*bgv,*gv; + HV *stash; + CV *cv = sv_2cv(block, &stash, &gv, 0); + SV **args_copy = NULL; + I32 ret_gimme = GIMME_V; + + int argi = 1; /* "shift" the block */ + int reti = 0; + + if(!(items % 2) && ckWARN(WARN_MISC)) + warn("Odd number of elements in pairmap"); + + agv = gv_fetchpv("a", GV_ADD, SVt_PV); + bgv = gv_fetchpv("b", GV_ADD, SVt_PV); + SAVESPTR(GvSV(agv)); + SAVESPTR(GvSV(bgv)); +/* 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(!CvISXSUB(cv)) { + /* Since MULTICALL is about to move it */ + SV **stack = PL_stack_base + ax; + I32 ret_gimme = GIMME_V; + int i; + + dMULTICALL; + I32 gimme = G_ARRAY; + + 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; + + MULTICALL; + count = PL_stack_sp - PL_stack_base; + + if(count > 2 && !args_copy) { + /* 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. + * 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); + + Copy(stack + argi, args_copy, n_args, SV *); + + argi = 0; + items = n_args; + } + + for(i = 0; i < count; i++) + stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]); + } + POP_MULTICALL; + + if(ret_gimme == G_ARRAY) + for(i = 0; i < reti; i++) + sv_2mortal(stack[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; + + PUSHMARK(SP); + count = call_sv((SV*)cv, G_ARRAY); + + SPAGAIN; + + if(count > 2 && !args_copy && ret_gimme == G_ARRAY) { + int n_args = items - argi; + Newx(args_copy, n_args, SV *); + SAVEFREEPV(args_copy); + + Copy(&ST(argi), args_copy, n_args, SV *); + + argi = 0; + items = n_args; + } + + if(ret_gimme == G_ARRAY) + for(i = 0; i < count; i++) + ST(reti++) = sv_mortalcopy(SP[i - count + 1]); + else + reti += count; + + PUTBACK; + } + } + + if(ret_gimme == G_ARRAY) + XSRETURN(reti); + + ST(0) = sv_2mortal(newSViv(reti)); + XSRETURN(1); +} + +void +pairs(...) +PROTOTYPE: @ +PPCODE: +{ + int argi = 0; + int reti = 0; + + if(items % 2 && ckWARN(WARN_MISC)) + warn("Odd number of elements in pairs"); + + { + for(; argi < items; argi += 2) { + SV *a = ST(argi); + SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef; + + AV *av = newAV(); + av_push(av, newSVsv(a)); + av_push(av, newSVsv(b)); + + ST(reti++) = sv_2mortal(newRV_noinc((SV *)av)); + } + } + + XSRETURN(reti); +} + +void +pairkeys(...) +PROTOTYPE: @ +PPCODE: +{ + int argi = 0; + int reti = 0; + + if(items % 2 && ckWARN(WARN_MISC)) + warn("Odd number of elements in pairkeys"); + + { + for(; argi < items; argi += 2) { + SV *a = ST(argi); + + ST(reti++) = sv_2mortal(newSVsv(a)); + } + } + + XSRETURN(reti); +} + +void +pairvalues(...) +PROTOTYPE: @ +PPCODE: +{ + int argi = 0; + int reti = 0; + + if(items % 2 && ckWARN(WARN_MISC)) + warn("Odd number of elements in pairvalues"); + + { + for(; argi < items; argi += 2) { + SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef; + + ST(reti++) = sv_2mortal(newSVsv(b)); + } + } + + XSRETURN(reti); +} + +void +shuffle(...) +PROTOTYPE: @ +CODE: +{ + int index; +#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 + + for (index = items ; index > 1 ; ) { + int swap = (int)(Drand01() * (double)(index--)); + SV *tmp = ST(swap); + ST(swap) = ST(index); + ST(index) = tmp; + } + + XSRETURN(items); +} + + +MODULE=List::Util PACKAGE=Scalar::Util + +void +dualvar(num,str) + SV *num + SV *str +PROTOTYPE: $$ +CODE: +{ + dXSTARG; + + (void)SvUPGRADE(TARG, SVt_PVNV); + + sv_copypv(TARG,str); + + if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { + SvNV_set(TARG, SvNV(num)); + SvNOK_on(TARG); + } +#ifdef SVf_IVisUV + else if(SvUOK(num)) { + SvUV_set(TARG, SvUV(num)); + SvIOK_on(TARG); + SvIsUV_on(TARG); + } +#endif + else { + SvIV_set(TARG, SvIV(num)); + SvIOK_on(TARG); + } + + if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) + SvTAINTED_on(TARG); + + ST(0) = TARG; + XSRETURN(1); +} + +void +isdual(sv) + SV *sv +PROTOTYPE: $ +CODE: + if(SvMAGICAL(sv)) + mg_get(sv); + + ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv))); + XSRETURN(1); + +char * +blessed(sv) + SV *sv +PROTOTYPE: $ +CODE: +{ + SvGETMAGIC(sv); + + if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) + XSRETURN_UNDEF; + + RETVAL = (char*)sv_reftype(SvRV(sv),TRUE); +} +OUTPUT: + RETVAL + +char * +reftype(sv) + SV *sv +PROTOTYPE: $ +CODE: +{ + SvGETMAGIC(sv); + if(!SvROK(sv)) + XSRETURN_UNDEF; + + RETVAL = (char*)sv_reftype(SvRV(sv),FALSE); +} +OUTPUT: + RETVAL + +UV +refaddr(sv) + SV *sv +PROTOTYPE: $ +CODE: +{ + SvGETMAGIC(sv); + if(!SvROK(sv)) + XSRETURN_UNDEF; + + RETVAL = PTR2UV(SvRV(sv)); +} +OUTPUT: + RETVAL + +void +weaken(sv) + SV *sv +PROTOTYPE: $ +CODE: +#ifdef SvWEAKREF + sv_rvweaken(sv); +#else + croak("weak references are not implemented in this release of perl"); +#endif + +void +isweak(sv) + SV *sv +PROTOTYPE: $ +CODE: +#ifdef SvWEAKREF + ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); + XSRETURN(1); +#else + croak("weak references are not implemented in this release of perl"); +#endif + +int +readonly(sv) + SV *sv +PROTOTYPE: $ +CODE: + SvGETMAGIC(sv); + RETVAL = SvREADONLY(sv); +OUTPUT: + RETVAL + +int +tainted(sv) + SV *sv +PROTOTYPE: $ +CODE: + SvGETMAGIC(sv); + RETVAL = SvTAINTED(sv); +OUTPUT: + RETVAL + +void +isvstring(sv) + SV *sv +PROTOTYPE: $ +CODE: +#ifdef SvVOK + SvGETMAGIC(sv); + ST(0) = boolSV(SvVOK(sv)); + XSRETURN(1); +#else + croak("vstrings are not implemented in this release of perl"); +#endif + +int +looks_like_number(sv) + SV *sv +PROTOTYPE: $ +CODE: + SV *tempsv; + SvGETMAGIC(sv); + if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) { + sv = tempsv; + } +#if PERL_BCDVERSION < 0x5008005 + if(SvPOK(sv) || SvPOKp(sv)) { + RETVAL = looks_like_number(sv); + } + else { + RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); + } +#else + RETVAL = looks_like_number(sv); +#endif +OUTPUT: + RETVAL + +void +set_prototype(subref, proto) + SV *subref + SV *proto +PROTOTYPE: &$ +CODE: +{ + if(SvROK(subref)) { + SV *sv = SvRV(subref); + if(SvTYPE(sv) != SVt_PVCV) { + /* not a subroutine reference */ + croak("set_prototype: not a subroutine reference"); + } + if(SvPOK(proto)) { + /* set the prototype */ + sv_copypv(sv, proto); + } + else { + /* delete the prototype */ + SvPOK_off(sv); + } + } + else { + croak("set_prototype: not a reference"); + } + XSRETURN(1); +} + +void +openhandle(SV *sv) +PROTOTYPE: $ +CODE: +{ + IO *io = NULL; + SvGETMAGIC(sv); + if(SvROK(sv)){ + /* deref first */ + sv = SvRV(sv); + } + + /* must be GLOB or IO */ + if(isGV(sv)){ + io = GvIO((GV*)sv); + } + else if(SvTYPE(sv) == SVt_PVIO){ + io = (IO*)sv; + } + + if(io){ + /* real or tied filehandle? */ + if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){ + XSRETURN(1); + } + } + XSRETURN_UNDEF; +} + +BOOT: +{ + HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE); + GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE); + SV *rmcsv; +#if !defined(SvWEAKREF) || !defined(SvVOK) + HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE); + GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE); + AV *varav; + if(SvTYPE(vargv) != SVt_PVGV) + gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE); + varav = GvAVn(vargv); +#endif + if(SvTYPE(rmcgv) != SVt_PVGV) + gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE); + rmcsv = GvSVn(rmcgv); +#ifndef SvWEAKREF + av_push(varav, newSVpv("weaken",6)); + av_push(varav, newSVpv("isweak",6)); +#endif +#ifndef SvVOK + av_push(varav, newSVpv("isvstring",9)); +#endif +#ifdef REAL_MULTICALL + sv_setsv(rmcsv, &PL_sv_yes); +#else + sv_setsv(rmcsv, &PL_sv_no); +#endif +} diff --git a/cpan/Scalar-List-Utils/Makefile.PL b/cpan/Scalar-List-Utils/Makefile.PL new file mode 100644 index 0000000000..5068e34598 --- /dev/null +++ b/cpan/Scalar-List-Utils/Makefile.PL @@ -0,0 +1,46 @@ +# -*- perl -*- +BEGIN { require 5.006; } +use strict; +use warnings; +use Config; +use File::Spec; +use ExtUtils::MakeMaker; +my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV; + +WriteMakefile( + NAME => q[List::Util], + ABSTRACT => q[Common Scalar and List utility subroutines], + AUTHOR => q[Graham Barr <gbarr@cpan.org>], + DEFINE => q[-DPERL_EXT], + DISTNAME => q[Scalar-List-Utils], + VERSION_FROM => 'lib/List/Util.pm', + + # We go through the ListUtil.xs trickery to foil platforms + # that have the feature combination of + # (1) static builds + # (2) allowing only one object by the same name in the static library + # (3) the object name matching being case-blind + # This means that we can't have the top-level util.o + # and the extension-level Util.o in the same build. + # One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform. + XS => {'ListUtil.xs' => 'ListUtil.c'}, + OBJECT => 'ListUtil$(OBJ_EXT)', + ( $PERL_CORE + ? () + : ( + 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.46) } ? ( + META_MERGE => { + resources => { ## + repository => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils', + }, + } + ) + : () + ), + ) + ), +); + diff --git a/cpan/Scalar-List-Utils/lib/List/Util.pm b/cpan/Scalar-List-Utils/lib/List/Util.pm new file mode 100644 index 0000000000..452dd2921f --- /dev/null +++ b/cpan/Scalar-List-Utils/lib/List/Util.pm @@ -0,0 +1,353 @@ +# List::Util.pm +# +# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk> + +package List::Util; + +use strict; +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + all any first min max minstr maxstr none notall product reduce sum sum0 shuffle + pairmap pairgrep pairfirst pairs pairkeys pairvalues +); +our $VERSION = "1.35"; +our $XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +require XSLoader; +XSLoader::load('List::Util', $XS_VERSION); + +sub import +{ + my $pkg = caller; + + # (RT88848) Touch the caller's $a and $b, to avoid the warning of + # Name "main::a" used only once: possible typo" warning + no strict 'refs'; + ${"${pkg}::a"} = ${"${pkg}::a"}; + ${"${pkg}::b"} = ${"${pkg}::b"}; + + goto &Exporter::import; +} + +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); + +=head1 DESCRIPTION + +C<List::Util> 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. + +By default C<List::Util> does not export any subroutines. + +=cut + +=head1 LIST-REDUCTION FUNCTIONS + +The following set of functions all reduce a list down to a single value. + +=cut + +=head2 reduce BLOCK LIST + +Reduces LIST by calling BLOCK, 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> set to the first two elements of the list, subsequent +calls will be done by setting C<$a> to the result of the previous +call and C<$b> to the next element in the list. + +Returns the result of the last call to BLOCK. If LIST is empty then +C<undef> is returned. If LIST only contains one element then that +element is returned and BLOCK is not executed. + +The following examples all demonstrate how C<reduce> could be used to +implement the other list-reduction functions in this module. (They are +not in fact implemented like this, but instead in a more efficient +manner in individual C functions). + + $foo = reduce { defined($a) ? $a : + $code->(local $_ = $b) ? $b : + undef } undef, @list # first + + $foo = reduce { $a > $b ? $a : $b } 1..10 # max + $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' # maxstr + $foo = reduce { $a < $b ? $a : $b } 1..10 # min + $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr + $foo = reduce { $a + $b } 1 .. 10 # sum + $foo = reduce { $a . $b } @bar # concat + + $foo = reduce { $a || $code->(local $_ = $b) } 0, @bar # any + $foo = reduce { $a && $code->(local $_ = $b) } 1, @bar # all + $foo = reduce { $a && !$code->(local $_ = $b) } 1, @bar # none + $foo = reduce { $a || !$code->(local $_ = $b) } 0, @bar # notall + # Note that these implementations do not fully short-circuit + +If your algorithm requires that C<reduce> produce an identity value, then +make sure that you always pass that identity value as the first argument to prevent +C<undef> being returned + + $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value + +The remaining list-reduction functions are all specialisations of this +generic idea. + +=head2 any BLOCK LIST + +Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element +of LIST in turn. C<any> returns true if any element makes the BLOCK return a +true value. If BLOCK never returns true or LIST was empty then it returns +false. + +Many cases of using C<grep> in a conditional can be written using C<any> +instead, as it can short-circuit after the first true result. + + if( any { length > 10 } @strings ) { + # at least one string has more than 10 characters + } + +=head2 all BLOCK LIST + +Similar to C<any>, except that it requires all elements of the LIST to make +the BLOCK return true. If any element returns false, then it returns true. If +the BLOCK never returns false or the LIST was empty then it returns true. + +=head2 none BLOCK LIST + +=head2 notall BLOCK LIST + +Similar to C<any> and C<all>, but with the return sense inverted. C<none> +returns true if no value in the LIST causes the BLOCK to return true, and +C<notall> returns true if not all of the values do. + +=head2 first BLOCK LIST + +Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element +of LIST in turn. C<first> returns the first element where the result from +BLOCK is a true value. If BLOCK never returns true or LIST was empty then +C<undef> is returned. + + $foo = first { defined($_) } @list # first defined value in @list + $foo = first { $_ > $value } @list # first value in @list which + # is greater than $value + +=head2 max LIST + +Returns the entry in the list with the highest numerical value. If the +list is empty then C<undef> is returned. + + $foo = max 1..10 # 10 + $foo = max 3,9,12 # 12 + $foo = max @bar, @baz # whatever + +=head2 maxstr LIST + +Similar to C<max>, but treats all the entries in the list as strings +and returns the highest string as defined by the C<gt> operator. +If the list is empty then C<undef> is returned. + + $foo = maxstr 'A'..'Z' # 'Z' + $foo = maxstr "hello","world" # "world" + $foo = maxstr @bar, @baz # whatever + +=head2 min LIST + +Similar to C<max> but returns the entry in the list with the lowest +numerical value. If the list is empty then C<undef> is returned. + + $foo = min 1..10 # 1 + $foo = min 3,9,12 # 3 + $foo = min @bar, @baz # whatever + +=head2 minstr LIST + +Similar to C<min>, but treats all the entries in the list as strings +and returns the lowest string as defined by the C<lt> operator. +If the list is empty then C<undef> is returned. + + $foo = minstr 'A'..'Z' # 'A' + $foo = minstr "hello","world" # "hello" + $foo = minstr @bar, @baz # whatever + +=head2 product LIST + +Returns the product of all the elements in LIST. If LIST is empty then C<1> is +returned. + + $foo = product 1..10 # 3628800 + $foo = product 3,9,12 # 324 + +=head2 sum LIST + +Returns the sum of all the elements in LIST. If LIST is empty then +C<undef> is returned. + + $foo = sum 1..10 # 55 + $foo = sum 3,9,12 # 24 + $foo = sum @bar, @baz # whatever + +=head2 sum0 LIST + +Similar to C<sum>, except this returns 0 when given an empty list, rather +than C<undef>. + +=cut + +=head1 KEY/VALUE PAIR LIST FUNCTIONS + +The following set of functions, all inspired by L<List::Pairwise>, consume +an even-sized list of pairs. The pairs may be key/value associations from a +hash, or just a list of values. The functions will all preserve the original +ordering of the pairs, and will not be confused by multiple pairs having the +same "key" value - nor even do they require that the first of each pair be a +plain string. + +=cut + +=head2 pairgrep BLOCK KVLIST + +Similar to perl's C<grep> keyword, but interprets the given list as an +even-sized list of pairs. It invokes the BLOCK multiple times, in scalar +context, with C<$a> and C<$b> set to successive pairs of values from the +KVLIST. + +Returns an even-sized list of those pairs for which the BLOCK returned true +in list context, or the count of the B<number of pairs> in scalar context. +(Note, therefore, in scalar context that it returns a number half the size +of the count of items it would have returned in list context). + + @subset = pairgrep { $a =~ m/^[[:upper:]]+$/ } @kvlist + +Similar to C<grep>, C<pairgrep> aliases C<$a> and C<$b> to elements of the +given list. Any modifications of it by the code block will be visible to +the caller. + +=head2 pairfirst BLOCK KVLIST + +Similar to the C<first> function, but interprets the given list as an +even-sized list of pairs. It invokes the BLOCK multiple times, in scalar +context, with C<$a> and C<$b> set to successive pairs of values from the +KVLIST. + +Returns the first pair of values from the list for which the BLOCK returned +true in list context, or an empty list of no such pair was found. In scalar +context it returns a simple boolean value, rather than either the key or the +value found. + + ( $key, $value ) = pairfirst { $a =~ m/^[[:upper:]]+$/ } @kvlist + +Similar to C<grep>, C<pairfirst> aliases C<$a> and C<$b> to elements of the +given list. Any modifications of it by the code block will be visible to +the caller. + +=head2 pairmap BLOCK KVLIST + +Similar to perl's C<map> keyword, but interprets the given list as an +even-sized list of pairs. It invokes the BLOCK multiple times, in list +context, with C<$a> and C<$b> set to successive pairs of values from the +KVLIST. + +Returns the concatenation of all the values returned by the BLOCK in list +context, or the count of the number of items that would have been returned +in scalar context. + + @result = pairmap { "The key $a has value $b" } @kvlist + +Similar to C<map>, C<pairmap> aliases C<$a> and C<$b> to elements of the +given list. Any modifications of it by the code block will be visible to +the caller. + +=head2 pairs KVLIST + +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 + + pairmap { [ $a, $b ] } KVLIST + +It is most convenient to use in a C<foreach> loop, for example: + + foreach ( pairs @KVLIST ) { + my ( $key, $value ) = @$_; + ... + } + +=head2 pairkeys KVLIST + +A convenient shortcut to operating on even-sized lists of pairs, this +function returns a list of the the first values of each of the pairs in +the given list. It is a more efficient version of + + pairmap { $a } KVLIST + +=head2 pairvalues KVLIST + +A convenient shortcut to operating on even-sized lists of pairs, this +function returns a list of the the second values of each of the pairs in +the given list. It is a more efficient version of + + pairmap { $b } KVLIST + +=cut + +=head1 OTHER FUNCTIONS + +=cut + +=head2 shuffle LIST + +Returns the elements of LIST in a random order + + @cards = shuffle 0..51 # 0..51 in a random order + +=cut + +=head1 KNOWN BUGS + +With perl versions prior to 5.005 there are some cases where reduce +will return an incorrect result. This will show up as test 7 of +reduce.t failing. + +=head1 SUGGESTED ADDITIONS + +The following are additions that have been requested, but I have been reluctant +to add due to them being very simple to implement in perl + + # How many elements are true + + sub true { scalar grep { $_ } @_ } + + # How many elements are false + + sub false { scalar grep { !$_ } @_ } + +=head1 SEE ALSO + +L<Scalar::Util>, L<List::MoreUtils> + +=head1 COPYRIGHT + +Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Recent additions and current maintenance by +Paul Evans, <leonerd@leonerd.org.uk>. + +=cut diff --git a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm new file mode 100644 index 0000000000..0625a0ae64 --- /dev/null +++ b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm @@ -0,0 +1,41 @@ +package List::Util::XS; +use strict; +use List::Util; + +our $VERSION = "1.35"; # FIXUP +$VERSION = eval $VERSION; # FIXUP + +1; +__END__ + +=head1 NAME + +List::Util::XS - Indicate if List::Util was compiled with a C compiler + +=head1 SYNOPSIS + + use List::Util::XS 1.20; + +=head1 DESCRIPTION + +C<List::Util::XS> can be used as a dependency to ensure List::Util was +installed using a C compiler and that the XS version is installed. + +During installation C<$List::Util::XS::VERSION> will be set to +C<undef> if the XS was not compiled. + +Starting with release 1.23_03, Scalar-List-Util is B<always> using +the XS implementation, but for backwards compatibility, we still +ship the C<List::Util::XS> module which just loads C<List::Util>. + +=head1 SEE ALSO + +L<Scalar::Util>, L<List::Util>, L<List::MoreUtils> + +=head1 COPYRIGHT + +Copyright (c) 2008 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm new file mode 100644 index 0000000000..edcaf1cb5b --- /dev/null +++ b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm @@ -0,0 +1,305 @@ +# Scalar::Util.pm +# +# Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk> + +package Scalar::Util; + +use strict; +require Exporter; +require List::Util; # List::Util loads the XS + +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( + blessed + dualvar + isdual + isvstring + isweak + looks_like_number + openhandle + readonly + refaddr + reftype + set_prototype + tainted + weaken +); +our $VERSION = "1.35"; +$VERSION = eval $VERSION; + +our @EXPORT_FAIL; + +unless (defined &weaken) { + push @EXPORT_FAIL, qw(weaken); +} +unless (defined &isweak) { + push @EXPORT_FAIL, qw(isweak isvstring); +} +unless (defined &isvstring) { + push @EXPORT_FAIL, qw(isvstring); +} + +sub export_fail { + if (grep { /^(?:weaken|isweak)$/ } @_ ) { + require Carp; + Carp::croak("Weak references are not implemented in the version of perl"); + } + + if (grep { /^isvstring$/ } @_ ) { + require Carp; + Carp::croak("Vstrings are not implemented in the version of perl"); + } + + @_; +} + +1; + +__END__ + +=head1 NAME + +Scalar::Util - A selection of general-utility scalar subroutines + +=head1 SYNOPSIS + + use Scalar::Util qw(blessed dualvar isdual readonly refaddr reftype + tainted weaken isweak isvstring looks_like_number + set_prototype); + # and other useful utils appearing below + +=head1 DESCRIPTION + +C<Scalar::Util> 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. + +By default C<Scalar::Util> does not export any subroutines. The +subroutines defined are + +=head2 blessed EXPR + +If EXPR evaluates to a blessed reference the name of the package +that it is blessed into is returned. Otherwise C<undef> is returned. + + $scalar = "foo"; + $class = blessed $scalar; # undef + + $ref = []; + $class = blessed $ref; # undef + + $obj = bless [], "Foo"; + $class = blessed $obj; # "Foo" + +Take care when using this function simply as a truth test (such as in +C<if(blessed $ref)...>) because the package name C<"0"> is defined yet +false. + +=head2 dualvar NUM, STRING + +Returns a scalar that has the value NUM in a numeric context and the +value STRING in a string context. + + $foo = dualvar 10, "Hello"; + $num = $foo + 2; # 12 + $str = $foo . " world"; # Hello world + +=head2 isdual EXPR + +If EXPR is a scalar that is a dualvar, the result is true. + + $foo = dualvar 86, "Nix"; + $dual = isdual($foo); # true + +Note that a scalar can be made to have both string and numeric content +through numeric operations: + + $foo = "10"; + $dual = isdual($foo); # false + $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: + + $! = 1; + print("$!\n"); # "Operation not permitted" + $dual = isdual($!); # false + +You can capture its numeric and string content using: + + $err = dualvar $!, $!; + $dual = isdual($err); # true + +=head2 isvstring EXPR + +If EXPR is a scalar which was coded as a vstring the result is true. + + $vs = v49.46.48; + $fmt = isvstring($vs) ? "%vd" : "%s"; #true + printf($fmt,$vs); + +=head2 looks_like_number EXPR + +Returns true if perl thinks EXPR is a number. See +L<perlapi/looks_like_number>. + +=head2 openhandle FH + +Returns FH if FH may be used as a filehandle and is open, or FH is a tied +handle. Otherwise C<undef> is returned. + + $fh = openhandle(*STDIN); # \*STDIN + $fh = openhandle(\*STDIN); # \*STDIN + $fh = openhandle(*NOTOPEN); # undef + $fh = openhandle("scalar"); # undef + +=head2 readonly SCALAR + +Returns true if SCALAR is readonly. + + sub foo { readonly($_[0]) } + + $readonly = foo($bar); # false + $readonly = foo(0); # true + +=head2 refaddr EXPR + +If EXPR evaluates to a reference the internal memory address of +the referenced value is returned. Otherwise C<undef> is returned. + + $addr = refaddr "string"; # undef + $addr = refaddr \$var; # eg 12345678 + $addr = refaddr []; # eg 23456784 + + $obj = bless {}, "Foo"; + $addr = refaddr $obj; # eg 88123488 + +=head2 reftype EXPR + +If EXPR evaluates to a reference the type of the variable referenced +is returned. Otherwise C<undef> is returned. + + $type = reftype "string"; # undef + $type = reftype \$var; # SCALAR + $type = reftype []; # ARRAY + + $obj = bless {}, "Foo"; + $type = reftype $obj; # HASH + +=head2 set_prototype CODEREF, PROTOTYPE + +Sets the prototype of the given function, or deletes it if PROTOTYPE is +undef. Returns the CODEREF. + + set_prototype \&foo, '$$'; + +=head2 tainted EXPR + +Return true if the result of EXPR is tainted + + $taint = tainted("constant"); # false + $taint = tainted($ENV{PWD}); # true if running under -T + +=head2 weaken REF + +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 reference +count on that object reaches zero, REF will be set to undef. + +This is useful for keeping copies of references , but you don't want to +prevent the object being DESTROY-ed at its usual time. + + { + my $var; + $ref = \$var; + weaken($ref); # Make $ref a weak reference + } + # $ref is now undef + +Note that if you take a copy of a scalar with a weakened reference, +the copy will be a strong reference. + + my $var; + my $foo = \$var; + weaken($foo); # Make $foo a weak reference + my $bar = $foo; # $bar is now a strong reference + +This may be less obvious in other situations, such as C<grep()>, for instance +when grepping through a list of weakened references to objects that may have +been destroyed already: + + @object = grep { defined } @object; + +This will indeed remove all references to destroyed objects, but the remaining +references to objects will be strong, causing the remaining objects to never +be destroyed because there is now always a strong reference to them in the +@object array. + +=head2 isweak EXPR + +If EXPR is a scalar which is a weak reference the result is true. + + $ref = \$foo; + $weak = isweak($ref); # false + weaken($ref); + $weak = isweak($ref); # true + +B<NOTE>: Copying a weak reference creates a normal, strong, reference. + + $copy = $ref; + $weak = isweak($copy); # false + +=head1 DIAGNOSTICS + +Module use may give one of the following errors during import. + +=over + +=item Weak references are not implemented in the version of perl + +The version of perl that you are using does not implement weak references, to use +C<isweak> or C<weaken> you will need to use a newer release of perl. + +=item Vstrings are not implemented in the version of perl + +The version of perl that you are using does not implement Vstrings, to use +C<isvstring> you will need to use a newer release of perl. + +=item C<NAME> is only available with the XS version of Scalar::Util + +C<Scalar::Util> 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 + +=head1 KNOWN BUGS + +There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will +show up as tests 8 and 9 of dualvar.t failing + +=head1 SEE ALSO + +L<List::Util> + +=head1 COPYRIGHT + +Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +Except weaken and isweak which are + +Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as perl itself. + +=cut diff --git a/cpan/Scalar-List-Utils/multicall.h b/cpan/Scalar-List-Utils/multicall.h new file mode 100644 index 0000000000..b8296e1755 --- /dev/null +++ b/cpan/Scalar-List-Utils/multicall.h @@ -0,0 +1,166 @@ +/* multicall.h (version 1.0) + * + * Implements a poor-man's MULTICALL interface for old versions + * of perl that don't offer a proper one. Intended to be compatible + * with 5.6.0 and later. + * + */ + +#ifdef dMULTICALL +#define REAL_MULTICALL +#else +#undef REAL_MULTICALL + +/* In versions of perl where MULTICALL is not defined (i.e. prior + * to 5.9.4), Perl_pad_push is not exported either. It also has + * an extra argument in older versions; certainly in the 5.8 series. + * So we redefine it here. + */ + +#ifndef AVf_REIFY +# ifdef SVpav_REIFY +# define AVf_REIFY SVpav_REIFY +# else +# error Neither AVf_REIFY nor SVpav_REIFY is defined +# endif +#endif + +#ifndef AvFLAGS +# define AvFLAGS SvFLAGS +#endif + +static void +multicall_pad_push(pTHX_ AV *padlist, int depth) +{ + if (depth <= AvFILLp(padlist)) + return; + + { + SV** const svp = AvARRAY(padlist); + AV* const newpad = newAV(); + SV** const oldpad = AvARRAY(svp[depth-1]); + I32 ix = AvFILLp((AV*)svp[1]); + const I32 names_fill = AvFILLp((AV*)svp[0]); + SV** const names = AvARRAY(svp[0]); + AV *av; + + for ( ;ix > 0; ix--) { + if (names_fill >= ix && names[ix] != &PL_sv_undef) { + const char sigil = SvPVX(names[ix])[0]; + if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') { + /* outer lexical or anon code */ + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { /* our own lexical */ + SV *sv; + if (sigil == '@') + sv = (SV*)newAV(); + else if (sigil == '%') + sv = (SV*)newHV(); + else + sv = NEWSV(0, 0); + av_store(newpad, ix, sv); + SvPADMY_on(sv); + } + } + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { + /* save temporaries on recursion? */ + SV * const sv = NEWSV(0, 0); + av_store(newpad, ix, sv); + SvPADTMP_on(sv); + } + } + av = newAV(); + av_extend(av, 0); + av_store(newpad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; + + av_store(padlist, depth, (SV*)newpad); + AvFILLp(padlist) = depth; + } +} + +#define dMULTICALL \ + SV **newsp; /* set by POPBLOCK */ \ + PERL_CONTEXT *cx; \ + CV *multicall_cv; \ + OP *multicall_cop; \ + bool multicall_oldcatch; \ + U8 hasargs = 0 + +/* Between 5.9.1 and 5.9.2 the retstack was removed, and the + return op is now stored on the cxstack. */ +#define HAS_RETSTACK (\ + PERL_REVISION < 5 || \ + (PERL_REVISION == 5 && PERL_VERSION < 9) || \ + (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \ +) + + +/* PUSHSUB is defined so differently on different versions of perl + * that it's easier to define our own version than code for all the + * different possibilities. + */ +#if HAS_RETSTACK +# define PUSHSUB_RETSTACK(cx) +#else +# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop; +#endif +#define MULTICALL_PUSHSUB(cx, the_cv) \ + cx->blk_sub.cv = the_cv; \ + cx->blk_sub.olddepth = CvDEPTH(the_cv); \ + cx->blk_sub.hasargs = hasargs; \ + cx->blk_sub.lval = PL_op->op_private & \ + (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \ + PUSHSUB_RETSTACK(cx) \ + if (!CvDEPTH(the_cv)) { \ + (void)SvREFCNT_inc(the_cv); \ + (void)SvREFCNT_inc(the_cv); \ + SAVEFREESV(the_cv); \ + } + +#define PUSH_MULTICALL(the_cv) \ + STMT_START { \ + CV *_nOnclAshIngNamE_ = the_cv; \ + AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \ + multicall_cv = _nOnclAshIngNamE_; \ + ENTER; \ + multicall_oldcatch = CATCH_GET; \ + SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \ + CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ + SAVETMPS; SAVEVPTR(PL_op); \ + CATCH_SET(TRUE); \ + PUSHSTACKi(PERLSI_SORT); \ + PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \ + MULTICALL_PUSHSUB(cx, multicall_cv); \ + if (++CvDEPTH(multicall_cv) >= 2) { \ + PERL_STACK_OVERFLOW_CHECK(); \ + multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \ + } \ + SAVECOMPPAD(); \ + PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \ + PL_curpad = AvARRAY(PL_comppad); \ + multicall_cop = CvSTART(multicall_cv); \ + } STMT_END + +#define MULTICALL \ + STMT_START { \ + PL_op = multicall_cop; \ + CALLRUNOPS(aTHX); \ + } STMT_END + +#define POP_MULTICALL \ + STMT_START { \ + CvDEPTH(multicall_cv)--; \ + LEAVESUB(multicall_cv); \ + POPBLOCK(cx,PL_curpm); \ + POPSTACK; \ + CATCH_SET(multicall_oldcatch); \ + LEAVE; \ + SPAGAIN; \ + } STMT_END + +#endif diff --git a/cpan/Scalar-List-Utils/t/00version.t b/cpan/Scalar-List-Utils/t/00version.t new file mode 100644 index 0000000000..d475de488d --- /dev/null +++ b/cpan/Scalar-List-Utils/t/00version.t @@ -0,0 +1,25 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Scalar::Util (); +use List::Util (); +use List::Util::XS (); +use Test::More tests => 2; + +is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch"); +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"); + diff --git a/cpan/Scalar-List-Utils/t/any-all.t b/cpan/Scalar-List-Utils/t/any-all.t new file mode 100644 index 0000000000..6fbf89a6ec --- /dev/null +++ b/cpan/Scalar-List-Utils/t/any-all.t @@ -0,0 +1,33 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use List::Util qw(any all notall none); +use Test::More tests => 12; + +ok( (any { $_ == 1 } 1, 2, 3), 'any true' ); +ok( !(any { $_ == 1 } 2, 3, 4), 'any false' ); +ok( !(any { 1 }), 'any empty list' ); + +ok( (all { $_ == 1 } 1, 1, 1), 'all true' ); +ok( !(all { $_ == 1 } 1, 2, 3), 'all false' ); +ok( (all { 1 }), 'all empty list' ); + +ok( (notall { $_ == 1 } 1, 2, 3), 'notall true' ); +ok( !(notall { $_ == 1 } 1, 1, 1), 'notall false' ); +ok( !(notall { 1 }), 'notall empty list' ); + +ok( (none { $_ == 1 } 2, 3, 4), 'none true' ); +ok( !(none { $_ == 1 } 1, 2, 3), 'none false' ); +ok( (none { 1 }), 'none empty list' ); diff --git a/cpan/Scalar-List-Utils/t/blessed.t b/cpan/Scalar-List-Utils/t/blessed.t new file mode 100644 index 0000000000..ae292b9954 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/blessed.t @@ -0,0 +1,55 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Test::More tests => 11; +use Scalar::Util qw(blessed); +use vars qw($t $x); + +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'); + +$x = bless [], "ABC"; +is(blessed($x), "ABC", 'blessed ARRAY-ref'); + +$x = bless {}, "DEF"; +is(blessed($x), "DEF", 'blessed HASH-ref'); + +$x = bless {}, "0"; +cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref'); + +{ + my $blessed = do { + my $depth; + no warnings 'redefine'; + local *UNIVERSAL::can = sub { die "Burp!" if ++$depth > 2; blessed(shift) }; + $x = bless {}, "DEF"; + blessed($x); + }; + is($blessed, "DEF", 'recursion of UNIVERSAL::can'); +} + +{ + package Broken; + sub isa { die }; + sub can { die }; + + my $obj = bless [], __PACKAGE__; + ::is( ::blessed($obj), __PACKAGE__, "blessed on broken isa() and can()" ); +} + diff --git a/cpan/Scalar-List-Utils/t/dualvar.t b/cpan/Scalar-List-Utils/t/dualvar.t new file mode 100644 index 0000000000..0943c75545 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/dualvar.t @@ -0,0 +1,142 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Scalar::Util (); +use Test::More (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) + ? (skip_all => 'dualvar requires XS version') + : (tests => 41); +use Config; + +Scalar::Util->import('dualvar'); +Scalar::Util->import('isdual'); + +$var = dualvar( 2.2,"string"); + +ok( isdual($var), 'Is a dualvar'); +ok( $var == 2.2, 'Numeric value'); +ok( $var eq "string", 'String value'); + +$var2 = $var; + +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'); + +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'); + +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'); +} + +# Create a dualvar "the old fashioned way" +$var = "10"; +ok( ! isdual($var), 'Not a dualvar'); +my $foo = $var + 0; +ok( isdual($var), 'Is a dualvar'); + +{ + package Tied; + + sub TIESCALAR { bless {} } + sub FETCH { 7.5 } +} + +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'); + + +SKIP: { + skip("need utf8::is_utf8",2) unless defined &utf8::is_utf8; + ok(!!utf8::is_utf8(dualvar(1,chr(400))), 'utf8'); + ok( !utf8::is_utf8(dualvar(1,"abc")), 'not utf8'); +} + +BEGIN { + if($Config{'useithreads'}) { + require threads; import threads; + require threads::shared; import threads::shared; + require constant; import constant HAVE_THREADS => 1; + } + else { + require constant; import constant HAVE_THREADS => 0; + } +} + +SKIP: { + skip("Perl not compiled with 'useithreads'",20) unless HAVE_THREADS; + skip("Requires threads::shared v1.42 or later",20) unless ($threads::shared::VERSION >= 1.42); + + my $siv; + share($siv); + $siv = dualvar(42, 'Fourty-Two'); + + my $snv; + share($snv); + $snv = dualvar(3.14, 'PI'); + + my $suv; + share($suv); + my $bits = ($Config{'use64bitint'}) ? 63 : 31; + $suv = dualvar(1<<$bits, 'Large unsigned int'); + + ok($siv == 42, 'Shared IV number preserved'); + ok($siv eq 'Fourty-Two', 'Shared string preserved'); + ok(isdual($siv), 'Is a dualvar'); + ok($snv == 3.14, 'Shared NV number preserved'); + ok($snv eq 'PI', 'Shared string preserved'); + ok(isdual($snv), 'Is a dualvar'); + ok($suv == (1<<$bits), 'Shared UV number preserved'); + ok($suv > 0, 'Shared UV number preserved'); + ok($suv eq 'Large unsigned int', 'Shared string preserved'); + ok(isdual($suv), 'Is a dualvar'); + + my @ary; + share(@ary); + $ary[0] = $siv; + $ary[1] = $snv; + $ary[2] = $suv; + + ok($ary[0] == 42, 'Shared IV number preserved'); + ok($ary[0] eq 'Fourty-Two', 'Shared string preserved'); + ok(isdual($ary[0]), 'Is a dualvar'); + ok($ary[1] == 3.14, 'Shared NV number preserved'); + ok($ary[1] eq 'PI', 'Shared string preserved'); + ok(isdual($ary[1]), 'Is a dualvar'); + ok($ary[2] == (1<<$bits), 'Shared UV number preserved'); + ok($ary[2] > 0, 'Shared UV number preserved'); + ok($ary[2] eq 'Large unsigned int', 'Shared string preserved'); + ok(isdual($ary[2]), 'Is a dualvar'); +} + diff --git a/cpan/Scalar-List-Utils/t/first.t b/cpan/Scalar-List-Utils/t/first.t new file mode 100644 index 0000000000..497cdd5188 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/first.t @@ -0,0 +1,134 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use List::Util qw(first); +use Test::More; +plan tests => 22 + ($::PERL_ONLY ? 0 : 2); +my $v; + +ok(defined &first, 'defined'); + +$v = first { 8 == ($_ - 1) } 9,4,5,6; +is($v, 9, 'one more than 8'); + +$v = first { 0 } 1,2,3,4; +is($v, undef, 'none match'); + +$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)]; +is_deeply($v, [qw(d e f)], 'reference args'); + +# Check that eval{} inside the block works correctly +my $i = 0; +$v = first { eval { die }; ($i == 5, $i = $_)[0] } 0,1,2,3,4,5,5; +is($v, 5, 'use of eval'); + +$v = eval { first { die if $_ } 0,0,1 }; +is($v, undef, 'use of die'); + +sub foobar { first { !defined(wantarray) || wantarray } "not ","not ","not " } + +($v) = foobar(); +is($v, undef, 'wantarray'); + +# Can we leave the sub with 'return'? +$v = first {return ($_>6)} 2,4,6,12; +is($v, 12, 'return'); + +# ... even in a loop? +$v = first {while(1) {return ($_>6)} } 2,4,6,12; +is($v, 12, 'return from loop'); + +# Does it work from another package? +{ package Foo; + ::is(List::Util::first(sub{$_>4},(1..4,24)), 24, 'other package'); +} + +# Can we undefine a first sub while it's running? +sub self_immolate {undef &self_immolate; 1} +eval { $v = first \&self_immolate, 1,2; }; +like($@, qr/^Can't undef active subroutine/, "undef active sub"); + +# Redefining an active sub should not fail, but whether the +# redefinition takes effect immediately depends on whether we're +# running the Perl or XS implementation. + +sub self_updating { local $^W; *self_updating = sub{1} ;1} +eval { $v = first \&self_updating, 1,2; }; +is($@, '', 'redefine self'); + +{ my $failed = 0; + + sub rec { my $n = shift; + if (!defined($n)) { # No arg means we're being called by first() + return 1; } + if ($n<5) { rec($n+1); } + else { $v = first \&rec, 1,2; } + $failed = 1 if !defined $n; + } + + rec(1); + ok(!$failed, 'from active sub'); +} + +# Calling a sub from first should leave its refcount unchanged. +SKIP: { + skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT; + sub huge {$_>1E6} + my $refcnt = &Internals::SvREFCNT(\&huge); + $v = first \&huge, 1..6; + 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: { + + $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once + skip("Poor man's MULTICALL can't cope", 2) + if !$List::Util::REAL_MULTICALL; + + # Can we goto a label from the 'first' sub? + eval {()=first{goto foo} 1,2; foo: 1}; + like($@, qr/^Can't "goto" out of a pseudo block/, "goto label"); + + # 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; + +is first(\&XSUBC_TRUE, 42, 1, 2, 3), 42, 'XSUB callbacks'; +is first(\&XSUBC_FALSE, 42, 1, 2, 3), undef, 'XSUB callbacks'; + + +eval { &first(1) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &first(1,2) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &first(qw(a b)) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &first([],1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &first(+{},1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); + diff --git a/cpan/Scalar-List-Utils/t/getmagic-once.t b/cpan/Scalar-List-Utils/t/getmagic-once.t new file mode 100644 index 0000000000..00b3490783 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/getmagic-once.t @@ -0,0 +1,47 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} +use strict; +use Scalar::Util qw(blessed reftype refaddr); +use Test::More tests => 6; + +my $getmagic_count; + +{ + package T; + use Tie::Scalar; + use base qw(Tie::StdScalar); + + sub FETCH { + $getmagic_count++; + my($self) = @_; + return $self->SUPER::FETCH; + } +} + +tie my $var, 'T'; + +$var = bless {}; + +$getmagic_count = 0; +ok blessed($var); +is $getmagic_count, 1, 'blessed'; + +$getmagic_count = 0; +ok reftype($var); +is $getmagic_count, 1, 'reftype'; + +$getmagic_count = 0; +ok refaddr($var); +is $getmagic_count, 1, 'refaddr'; diff --git a/cpan/Scalar-List-Utils/t/isvstring.t b/cpan/Scalar-List-Utils/t/isvstring.t new file mode 100644 index 0000000000..860113e067 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/isvstring.t @@ -0,0 +1,33 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +$|=1; +use Scalar::Util (); +use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) + ? (skip_all => 'isvstring requires XS version') + : (tests => 3); + +Scalar::Util->import(qw[isvstring]); + +$vs = ord("A") == 193 ? 241.75.240 : 49.46.48; + +ok( $vs == "1.0", 'dotted num'); +ok( isvstring($vs), 'isvstring'); + +$sv = "1.0"; +ok( !isvstring($sv), 'not isvstring'); + + + diff --git a/cpan/Scalar-List-Utils/t/lln.t b/cpan/Scalar-List-Utils/t/lln.t new file mode 100644 index 0000000000..1499cdb49d --- /dev/null +++ b/cpan/Scalar-List-Utils/t/lln.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 19; +use Scalar::Util qw(looks_like_number); + +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'); + +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'); + +{ package Foo; +sub TIEHASH { bless {} } +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("\x{1815}"), '', 'MONGOLIAN DIGIT FIVE'); + +# We should copy some of perl core tests like t/base/num.t here diff --git a/cpan/Scalar-List-Utils/t/max.t b/cpan/Scalar-List-Utils/t/max.t new file mode 100644 index 0000000000..9607015d83 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/max.t @@ -0,0 +1,76 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 10; +use List::Util qw(max); + +my $v; + +ok(defined &max, 'defined'); + +$v = max(1); +is($v, 1, 'single arg'); + +$v = max (1,2); +is($v, 2, '2-arg ordered'); + +$v = max(2,1); +is($v, 2, '2-arg reverse ordered'); + +my @a = map { rand() } 1 .. 20; +my @b = sort { $a <=> $b } @a; +$v = max(@a); +is($v, $b[-1], '20-arg random order'); + +my $one = Foo->new(1); +my $two = Foo->new(2); +my $thr = Foo->new(3); + +$v = max($one,$two,$thr); +is($v, 3, 'overload'); + +$v = max($thr,$two,$one); +is($v, 3, 'overload'); + + +{ package Foo; + +use overload + '""' => sub { ${$_[0]} }, + '+0' => sub { ${$_[0]} }, + '>' => sub { ${$_[0]} > ${$_[1]} }, + fallback => 1; + sub new { + my $class = shift; + my $value = shift; + bless \$value, $class; + } +} + +use Math::BigInt; + +my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65); +my $v2 = $v1 - 1; +my $v3 = $v2 - 1; +$v = max($v1,$v2,$v1,$v3,$v1); +is($v, $v1, 'bigint'); + +$v = max($v1, 1, 2, 3); +is($v, $v1, 'bigint and normal int'); + +$v = max(1, 2, $v1, 3); +is($v, $v1, 'bigint and normal int'); + diff --git a/cpan/Scalar-List-Utils/t/maxstr.t b/cpan/Scalar-List-Utils/t/maxstr.t new file mode 100644 index 0000000000..11d98ff558 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/maxstr.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 5; +use List::Util qw(maxstr); + +my $v; + +ok(defined &maxstr, 'defined'); + +$v = maxstr('a'); +is($v, 'a', 'single arg'); + +$v = maxstr('a','b'); +is($v, 'b', '2-arg ordered'); + +$v = maxstr('B','A'); +is($v, 'B', '2-arg reverse ordered'); + +my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20; +my @b = sort { $a cmp $b } @a; +$v = maxstr(@a); +is($v, $b[-1], 'random ordered'); diff --git a/cpan/Scalar-List-Utils/t/min.t b/cpan/Scalar-List-Utils/t/min.t new file mode 100644 index 0000000000..8d5be5e153 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/min.t @@ -0,0 +1,75 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 10; +use List::Util qw(min); + +my $v; + +ok(defined &min, 'defined'); + +$v = min(9); +is($v, 9, 'single arg'); + +$v = min (1,2); +is($v, 1, '2-arg ordered'); + +$v = min(2,1); +is($v, 1, '2-arg reverse ordered'); + +my @a = map { rand() } 1 .. 20; +my @b = sort { $a <=> $b } @a; +$v = min(@a); +is($v, $b[0], '20-arg random order'); + +my $one = Foo->new(1); +my $two = Foo->new(2); +my $thr = Foo->new(3); + +$v = min($one,$two,$thr); +is($v, 1, 'overload'); + +$v = min($thr,$two,$one); +is($v, 1, 'overload'); + +{ package Foo; + +use overload + '""' => sub { ${$_[0]} }, + '+0' => sub { ${$_[0]} }, + '<' => sub { ${$_[0]} < ${$_[1]} }, + fallback => 1; + sub new { + my $class = shift; + my $value = shift; + bless \$value, $class; + } +} + +use Math::BigInt; + +my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65); +my $v2 = $v1 - 1; +my $v3 = $v2 - 1; +$v = min($v1,$v2,$v1,$v3,$v1); +is($v, $v3, 'bigint'); + +$v = min($v1, 1, 2, 3); +is($v, 1, 'bigint and normal int'); + +$v = min(1, 2, $v1, 3); +is($v, 1, 'bigint and normal int'); + diff --git a/cpan/Scalar-List-Utils/t/minstr.t b/cpan/Scalar-List-Utils/t/minstr.t new file mode 100644 index 0000000000..021b309dad --- /dev/null +++ b/cpan/Scalar-List-Utils/t/minstr.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 5; +use List::Util qw(minstr); + +my $v; + +ok(defined &minstr, 'defined'); + +$v = minstr('a'); +is($v, 'a', 'single arg'); + +$v = minstr('a','b'); +is($v, 'a', '2-arg ordered'); + +$v = minstr('B','A'); +is($v, 'A', '2-arg reverse ordered'); + +my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20; +my @b = sort { $a cmp $b } @a; +$v = minstr(@a); +is($v, $b[0], 'random ordered'); diff --git a/cpan/Scalar-List-Utils/t/multicall-refcount.t b/cpan/Scalar-List-Utils/t/multicall-refcount.t new file mode 100644 index 0000000000..1d6fb59808 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/multicall-refcount.t @@ -0,0 +1,21 @@ +use Test::More tests => 1; + +use List::Util 'first'; + +our $comparison; + +sub foo { + if( $comparison ) { + return 1; + } + else { + local $comparison = 1; + first \&foo, 1,2,3; + } +} + +for(1,2){ + foo(); +} + +ok( "Didn't crash calling recursively" ); diff --git a/cpan/Scalar-List-Utils/t/openhan.t b/cpan/Scalar-List-Utils/t/openhan.t new file mode 100644 index 0000000000..e0dffb6f53 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/openhan.t @@ -0,0 +1,101 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; + +use Test::More tests => 21; +use Scalar::Util qw(openhandle); + +ok(defined &openhandle, 'defined'); + +{ + my $fh = \*STDERR; + is(openhandle($fh), $fh, 'STDERR'); + + is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)'); +} + +{ + use vars qw(*CLOSED); + is(openhandle(*CLOSED), undef, 'closed'); +} + +SKIP: { + skip "3-arg open only on 5.6 or later", 1 if $]<5.006; + + open my $fh, "<", $0; + skip "could not open $0 for reading: $!", 2 unless $fh; + is(openhandle($fh), $fh, "works with indirect filehandles"); + close($fh); + is(openhandle($fh), undef, "works with indirect filehandles"); +} + +SKIP: { + skip "in-memory files only on 5.8 or later", 2 if $]<5.008; + + open my $fh, "<", \"in-memory file"; + skip "could not open in-memory file: $!", 2 unless $fh; + is(openhandle($fh), $fh, "works with in-memory files"); + close($fh); + is(openhandle($fh), undef, "works with in-memory files"); +} + +ok(openhandle(\*DATA), "works for \*DATA"); +ok(openhandle(*DATA), "works for *DATA"); +ok(openhandle(*DATA{IO}), "works for *DATA{IO}"); + +{ + require IO::Handle; + my $fh = IO::Handle->new_from_fd(fileno(*STDERR), 'w'); + skip "new_from_fd(fileno(*STDERR)) failed", 2 unless $fh; + ok(openhandle($fh), "works for IO::Handle objects"); + + ok(!openhandle(IO::Handle->new), "unopened IO::Handle"); +} + +{ + require IO::File; + my $fh = IO::File->new; + $fh->open("< $0") + or skip "could not open $0: $!", 3; + ok(openhandle($fh), "works for IO::File objects"); + close($fh); + ok(!openhandle($fh), "works for IO::File objects"); + + ok(!openhandle(IO::File->new), "unopened IO::File" ); +} + +SKIP: { + skip( "Tied handles only on 5.8 or later", 2) if $]<5.008; + + use vars qw(*H); + + package My::Tie; + require Tie::Handle; + @My::Tie::ISA = qw(Tie::Handle); + sub TIEHANDLE { bless {} } + + package main; + tie *H, 'My::Tie'; + ok(openhandle(*H), "tied handles are always ok"); + ok(openhandle(\*H), "tied handle refs are always ok"); +} + +ok !openhandle(undef), "undef is not a filehandle"; +ok !openhandle("STDIN"), "strings are not filehandles"; +ok !openhandle(0), "integers are not filehandles"; + + +__DATA__ diff --git a/cpan/Scalar-List-Utils/t/pair.t b/cpan/Scalar-List-Utils/t/pair.t new file mode 100644 index 0000000000..46e05342ac --- /dev/null +++ b/cpan/Scalar-List-Utils/t/pair.t @@ -0,0 +1,97 @@ +#!./perl + +use strict; +use Test::More tests => 20; +use List::Util qw(pairgrep pairfirst pairmap pairs pairkeys pairvalues); + +no warnings 'misc'; # avoid "Odd number of elements" warnings most of the time + +is_deeply( [ pairgrep { $b % 2 } one => 1, two => 2, three => 3 ], + [ one => 1, three => 3 ], + 'pairgrep list' ); + +is( scalar( pairgrep { $b & 2 } one => 1, two => 2, three => 3 ), + 2, + 'pairgrep scalar' ); + +is_deeply( [ pairgrep { $a } 0 => "zero", 1 => "one", 2 ], + [ 1 => "one", 2 => undef ], + 'pairgrep pads with undef' ); + +{ + use warnings 'misc'; + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + + pairgrep { } one => 1, two => 2; + is( $warnings, "", 'even-sized list yields no warnings from pairgrep' ); + + pairgrep { } one => 1, two =>; + like( $warnings, qr/^Odd number of elements in pairgrep at /, + 'odd-sized list yields warning from pairgrep' ); +} + +{ + my @kvlist = ( one => 1, two => 2 ); + pairgrep { $b++ } @kvlist; + is_deeply( \@kvlist, [ one => 2, two => 3 ], 'pairgrep aliases elements' ); +} + +is_deeply( [ pairfirst { length $a == 5 } one => 1, two => 2, three => 3 ], + [ three => 3 ], + 'pairfirst list' ); + +is_deeply( [ pairfirst { length $a == 4 } one => 1, two => 2, three => 3 ], + [], + 'pairfirst list empty' ); + +is( scalar( pairfirst { length $a == 5 } one => 1, two => 2, three => 3 ), + 1, + 'pairfirst scalar true' ); + +ok( !scalar( pairfirst { length $a == 4 } one => 1, two => 2, three => 3 ), + 'pairfirst scalar false' ); + +is_deeply( [ pairmap { uc $a => $b } one => 1, two => 2, three => 3 ], + [ ONE => 1, TWO => 2, THREE => 3 ], + 'pairmap list' ); + +is( scalar( pairmap { qw( a b c ) } one => 1, two => 2 ), + 6, + 'pairmap scalar' ); + +is_deeply( [ pairmap { $a => @$b } one => [1,1,1], two => [2,2,2], three => [3,3,3] ], + [ one => 1, 1, 1, two => 2, 2, 2, three => 3, 3, 3 ], + 'pairmap list returning >2 items' ); + +is_deeply( [ pairmap { $b } one => 1, two => 2, three => ], + [ 1, 2, undef ], + 'pairmap pads with undef' ); + +{ + my @kvlist = ( one => 1, two => 2 ); + pairmap { $b++ } @kvlist; + is_deeply( \@kvlist, [ one => 2, two => 3 ], 'pairmap aliases elements' ); +} + +# Calculating a 1000-element list should hopefully cause the stack to move +# underneath pairmap +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' ); + +is_deeply( [ pairs one => 1, two => 2, three => 3 ], + [ [ one => 1 ], [ two => 2 ], [ three => 3 ] ], + 'pairs' ); + +is_deeply( [ pairs one => 1, two => ], + [ [ one => 1 ], [ two => undef ] ], + 'pairs pads with undef' ); + +is_deeply( [ pairkeys one => 1, two => 2 ], + [qw( one two )], + 'pairkeys' ); + +is_deeply( [ pairvalues one => 1, two => 2 ], + [ 1, 2 ], + 'pairvalues' ); diff --git a/cpan/Scalar-List-Utils/t/product.t b/cpan/Scalar-List-Utils/t/product.t new file mode 100644 index 0000000000..bed20cf8a5 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/product.t @@ -0,0 +1,98 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Test::More tests => 13; + +use List::Util qw(product); + +my $v = product; +is( $v, 1, 'no args'); + +$v = product(9); +is( $v, 9, 'one arg'); + +$v = product(1,2,3,4); +is( $v, 24, '4 args'); + +$v = product(-1); +is( $v, -1, 'one -1'); + +my $x = -3; + +$v = product($x, 3); +is( $v, -9, 'variable arg'); + +$v = product(-3.5,3); +is( $v, -10.5, 'real numbers'); + +my $one = Foo->new(1); +my $two = Foo->new(2); +my $four = Foo->new(4); + +$v = product($one,$two,$four); +is($v, 8, 'overload'); + + +{ package Foo; + +use overload + '""' => sub { ${$_[0]} }, + '+0' => sub { ${$_[0]} }, + fallback => 1; + sub new { + my $class = shift; + my $value = shift; + bless \$value, $class; + } +} + +use Math::BigInt; +my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65); +my $v2 = $v1 - 1; +$v = product($v1,$v2); +is($v, $v1 * $v2, 'bigint'); + +$v = product(42, $v1); +is($v, $v1 * 42, 'bigint + builtin int'); + +$v = product(42, $v1, 2); +is($v, $v1 * 42 * 2, 'bigint + builtin int'); + +{ package example; + + use overload + '0+' => sub { $_[0][0] }, + '""' => sub { my $r = "$_[0][0]"; $r = "+$r" unless $r =~ m/^\-/; $r .= " [$_[0][1]]"; $r }, + fallback => 1; + + sub new { + my $class = shift; + + my $this = bless [@_], $class; + + return $this; + } +} + +{ + my $e1 = example->new(7, "test"); + $t = product($e1, 7, 7); + is($t, 343, 'overload returning non-overload'); + $t = product(8, $e1, 8); + is($t, 448, 'overload returning non-overload'); + $t = product(9, 9, $e1); + is($t, 567, 'overload returning non-overload'); +} + diff --git a/cpan/Scalar-List-Utils/t/proto.t b/cpan/Scalar-List-Utils/t/proto.t new file mode 100644 index 0000000000..50e401b59e --- /dev/null +++ b/cpan/Scalar-List-Utils/t/proto.t @@ -0,0 +1,59 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Scalar::Util (); +use Test::More (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL) + ? (skip_all => 'set_prototype requires XS version') + : (tests => 13); + +Scalar::Util->import('set_prototype'); + +sub f { } +is( prototype('f'), undef, 'no prototype'); + +$r = set_prototype(\&f,'$'); +is( prototype('f'), '$', 'set prototype'); +is( $r, \&f, 'return value'); + +set_prototype(\&f,undef); +is( prototype('f'), undef, 'remove prototype'); + +set_prototype(\&f,''); +is( prototype('f'), '', 'empty prototype'); + +sub g (@) { } +is( prototype('g'), '@', '@ prototype'); + +set_prototype(\&g,undef); +is( prototype('g'), undef, 'remove prototype'); + +sub stub; +is( prototype('stub'), undef, 'non existing sub'); + +set_prototype(\&stub,'$$$'); +is( prototype('stub'), '$$$', 'change non existing sub'); + +sub f_decl ($$$$); +is( prototype('f_decl'), '$$$$', 'forward declaration'); + +set_prototype(\&f_decl,'\%'); +is( prototype('f_decl'), '\%', 'change forward declaration'); + +eval { &set_prototype( 'f', '' ); }; +print "not " unless +ok($@ =~ /^set_prototype: not a reference/, 'not a reference'); + +eval { &set_prototype( \'f', '' ); }; +ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference'); diff --git a/cpan/Scalar-List-Utils/t/readonly.t b/cpan/Scalar-List-Utils/t/readonly.t new file mode 100644 index 0000000000..91385fd18f --- /dev/null +++ b/cpan/Scalar-List-Utils/t/readonly.t @@ -0,0 +1,53 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Scalar::Util qw(readonly); +use Test::More tests => 11; + +ok( readonly(1), 'number constant'); + +my $var = 2; + +ok( !readonly($var), 'number variable'); +is( $var, 2, 'no change to number variable'); + +ok( readonly("fred"), 'string constant'); + +$var = "fred"; + +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(*STDOUT), 'glob'); + +sub try +{ + my $v = \$_[0]; + return readonly $$v; +} + +$var = 123; +{ + # This used not to work with ithreads, but seems to be working since 5.19.3 + local $TODO = ( $Config::Config{useithreads} && $] < 5.019003 ) ? + "doesn't work with threads" : undef; + ok( try ("abc"), 'reference a constant in a sub'); +} +ok( !try ($var), 'reference a non-constant in a sub'); diff --git a/cpan/Scalar-List-Utils/t/reduce.t b/cpan/Scalar-List-Utils/t/reduce.t new file mode 100644 index 0000000000..4468ab8611 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/reduce.t @@ -0,0 +1,169 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + + +use List::Util qw(reduce min); +use Test::More; +plan tests => 29 + ($::PERL_ONLY ? 0 : 2); + +my $v = reduce {}; + +is( $v, undef, 'no args'); + +$v = reduce { $a / $b } 756,3,7,4; +is( $v, 9, '4-arg divide'); + +$v = reduce { $a / $b } 6; +is( $v, 6, 'one arg'); + +@a = map { rand } 0 .. 20; +$v = reduce { $a < $b ? $a : $b } @a; +is( $v, min(@a), 'min'); + +@a = map { pack("C", int(rand(256))) } 0 .. 20; +$v = reduce { $a . $b } @a; +is( $v, join("",@a), 'concat'); + +sub add { + my($aa, $bb) = @_; + return $aa + $bb; +} + +$v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1; +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{}'); + +$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'); + +sub add2 { $a + $b } + +$v = reduce \&add2, 1,2,3; +is( $v, 6, 'sub reference'); + +$v = reduce { add2() } 3,4,5; +is( $v, 12, 'call sub'); + + +$v = reduce { eval "$a + $b" } 1,2,3; +is( $v, 6, 'eval string'); + +$a = 8; $b = 9; +$v = reduce { $a * $b } 1,2,3; +is( $a, 8, 'restore $a'); +is( $b, 9, 'restore $b'); + +# Can we leave the sub with 'return'? +$v = reduce {return $a+$b} 2,4,6; +is($v, 12, 'return'); + +# ... even in a loop? +$v = reduce {while(1) {return $a+$b} } 2,4,6; +is($v, 12, 'return from loop'); + +# Does it work from another package? +{ package Foo; + $a = $b; + ::is((List::Util::reduce {$a*$b} (1..4)), 24, 'other package'); +} + +# Can we undefine a reduce sub while it's running? +sub self_immolate {undef &self_immolate; 1} +eval { $v = reduce \&self_immolate, 1,2; }; +like($@, qr/^Can't undef active subroutine/, "undef active sub"); + +# Redefining an active sub should not fail, but whether the +# redefinition takes effect immediately depends on whether we're +# running the Perl or XS implementation. + +sub self_updating { local $^W; *self_updating = sub{1} ;1 } +eval { $v = reduce \&self_updating, 1,2; }; +is($@, '', 'redefine self'); + +{ my $failed = 0; + + sub rec { my $n = shift; + if (!defined($n)) { # No arg means we're being called by reduce() + return 1; } + if ($n<5) { rec($n+1); } + else { $v = reduce \&rec, 1,2; } + $failed = 1 if !defined $n; + } + + rec(1); + ok(!$failed, 'from active sub'); +} + +# Calling a sub from reduce should leave its refcount unchanged. +SKIP: { + skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT; + sub mult {$a*$b} + my $refcnt = &Internals::SvREFCNT(\&mult); + $v = reduce \&mult, 1..6; + is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged"); +} + +{ + my $ok = 'failed'; + local $SIG{__DIE__} = sub { $ok = $_[0] =~ /Not a (subroutine|CODE) reference/ ? '' : $_[0] }; + eval { &reduce('foo',1,2) }; + is($ok, '', 'Not a subroutine reference'); + $ok = 'failed'; + eval { &reduce({},1,2) }; + 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: { + + $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once + skip("Poor man's MULTICALL can't cope", 2) + if !$List::Util::REAL_MULTICALL; + + # Can we goto a label from the reduction sub? + eval {()=reduce{goto foo} 1,2; foo: 1}; + like($@, qr/^Can't "goto" out of a pseudo block/, "goto label"); + + # Can we goto a subroutine? + eval {()=reduce{goto sub{}} 1,2;}; + like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); + +} } + +# XSUB callback +use constant XSUBC => 42; + +is reduce(\&XSUBC, 1, 2, 3), 42, "xsub callbacks"; + +eval { &reduce(1) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &reduce(1,2) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &reduce(qw(a b)) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &reduce([],1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +eval { &reduce(+{},1,2,3) }; +ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); + diff --git a/cpan/Scalar-List-Utils/t/refaddr.t b/cpan/Scalar-List-Utils/t/refaddr.t new file mode 100644 index 0000000000..35ad40f620 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/refaddr.t @@ -0,0 +1,111 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + + +use Test::More tests => 32; + +use Scalar::Util qw(refaddr); +use vars qw($t $y $x *F $v $r); +use Symbol qw(gensym); + +# Ensure we do not trigger and tied methods +tie *F, 'MyTie'; + +my $i = 1; +foreach $v (undef, 10, 'string') { + is(refaddr($v), undef, "not " . (defined($v) ? "'$v'" : "undef")); +} + +foreach $r ({}, \$t, [], \*F, sub {}) { + my $n = "$r"; + $n =~ /0x(\w+)/; + my $addr = do { local $^W; hex $1 }; + my $before = ref($r); + is( refaddr($r), $addr, $n); + is( ref($r), $before, $n); + + my $obj = bless $r, 'FooBar'; + is( refaddr($r), $addr, "blessed with overload $n"); + is( ref($r), 'FooBar', $n); +} + +{ + my $z = '77'; + my $y = \$z; + my $a = '78'; + my $b = \$a; + tie my %x, 'Hash3', {}; + $x{$y} = 22; + $x{$b} = 23; + my $xy = $x{$y}; + my $xb = $x{$b}; + ok(ref($x{$y})); + ok(ref($x{$b})); + ok(refaddr($xy) == refaddr($y)); + ok(refaddr($xb) == refaddr($b)); + ok(refaddr($x{$y})); + ok(refaddr($x{$b})); +} +{ + my $z = bless {}, '0'; + ok(refaddr($z)); + @{"0::ISA"} = qw(FooBar); + my $a = {}; + my $r = refaddr($a); + $z = bless $a, '0'; + ok(refaddr($z) > 10); + is(refaddr($z),$r,"foo"); +} + +package FooBar; + +use overload '0+' => sub { 10 }, + '+' => sub { 10 + $_[1] }, + '"' => sub { "10" }; + +package MyTie; + +sub TIEHANDLE { bless {} } +sub DESTROY {} + +sub AUTOLOAD { + warn "$AUTOLOAD called"; + exit 1; # May be in an eval +} + +package Hash3; + +use Scalar::Util qw(refaddr); + +sub TIEHASH +{ + my $pkg = shift; + return bless [ @_ ], $pkg; +} +sub FETCH +{ + 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); +} diff --git a/cpan/Scalar-List-Utils/t/reftype.t b/cpan/Scalar-List-Utils/t/reftype.t new file mode 100644 index 0000000000..31a5d3b841 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/reftype.t @@ -0,0 +1,65 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Test::More tests => 32; + +use Scalar::Util qw(reftype); +use vars qw($t $y $x *F); +use Symbol qw(gensym); + +# Ensure we do not trigger and tied methods +tie *F, 'MyTie'; +my $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP'; + +my $s = []; # SvTYPE($s) is SVt_RV, and SvROK($s) is true +$s = undef; # SvTYPE($s) is SVt_RV, but SvROK($s) is false + +@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' ], +); + +foreach $test (@test) { + my($type,$what, $n) = @$test; + + is( reftype($what), $type, $n); + next unless ref($what); + + bless $what, "ABC"; + is( reftype($what), $type, $n); + + bless $what, "0"; + is( reftype($what), $type, $n); +} + +package MyTie; + +sub TIEHANDLE { bless {} } +sub DESTROY {} + +sub AUTOLOAD { + warn "$AUTOLOAD called"; + exit 1; # May be in an eval +} diff --git a/cpan/Scalar-List-Utils/t/shuffle.t b/cpan/Scalar-List-Utils/t/shuffle.t new file mode 100644 index 0000000000..d3fbd6cd1f --- /dev/null +++ b/cpan/Scalar-List-Utils/t/shuffle.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Test::More tests => 6; + +use List::Util qw(shuffle); + +my @r; + +@r = shuffle(); +ok( !@r, 'no args'); + +@r = shuffle(9); +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'); + +isnt( "@r", "@in", 'result different to args'); + +my @s = sort { $a <=> $b } @r; +is( "@in", "@s", 'values'); diff --git a/cpan/Scalar-List-Utils/t/stack-corruption.t b/cpan/Scalar-List-Utils/t/stack-corruption.t new file mode 100644 index 0000000000..dff5af03c4 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/stack-corruption.t @@ -0,0 +1,30 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } + if ($] eq "5.008009" or $] eq "5.010000" or $] le "5.006002") { + print "1..0 # Skip: known to fail on $]\n"; + exit 0; + } +} + +use List::Util qw(reduce); +use Test::More tests => 1; + +my $ret = "original"; +$ret = $ret . broken(); +is($ret, "originalreturn"); + +sub broken { + reduce { return "bogus"; } qw/some thing/; + return "return"; +} diff --git a/cpan/Scalar-List-Utils/t/sum.t b/cpan/Scalar-List-Utils/t/sum.t new file mode 100644 index 0000000000..3615b4ab41 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/sum.t @@ -0,0 +1,97 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Test::More tests => 13; + +use List::Util qw(sum); + +my $v = sum; +is( $v, undef, 'no args'); + +$v = sum(9); +is( $v, 9, 'one arg'); + +$v = sum(1,2,3,4); +is( $v, 10, '4 args'); + +$v = sum(-1); +is( $v, -1, 'one -1'); + +my $x = -3; + +$v = sum($x, 3); +is( $v, 0, 'variable arg'); + +$v = sum(-3.5,3); +is( $v, -0.5, 'real numbers'); + +my $one = Foo->new(1); +my $two = Foo->new(2); +my $thr = Foo->new(3); + +$v = sum($one,$two,$thr); +is($v, 6, 'overload'); + + +{ package Foo; + +use overload + '""' => sub { ${$_[0]} }, + '+0' => sub { ${$_[0]} }, + fallback => 1; + sub new { + my $class = shift; + my $value = shift; + bless \$value, $class; + } +} + +use Math::BigInt; +my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65); +my $v2 = $v1 - 1; +$v = sum($v1,$v2); +is($v, $v1 + $v2, 'bigint'); + +$v = sum(42, $v1); +is($v, $v1 + 42, 'bigint + builtin int'); + +$v = sum(42, $v1, 2); +is($v, $v1 + 42 + 2, 'bigint + builtin int'); + +{ package example; + + use overload + '0+' => sub { $_[0][0] }, + '""' => sub { my $r = "$_[0][0]"; $r = "+$r" unless $r =~ m/^\-/; $r .= " [$_[0][1]]"; $r }, + fallback => 1; + + sub new { + my $class = shift; + + my $this = bless [@_], $class; + + return $this; + } +} + +{ + my $e1 = example->new(7, "test"); + $t = sum($e1, 7, 7); + is($t, 21, 'overload returning non-overload'); + $t = sum(8, $e1, 8); + is($t, 23, 'overload returning non-overload'); + $t = sum(9, 9, $e1); + is($t, 25, 'overload returning non-overload'); +} diff --git a/cpan/Scalar-List-Utils/t/sum0.t b/cpan/Scalar-List-Utils/t/sum0.t new file mode 100644 index 0000000000..e76f8a79d3 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/sum0.t @@ -0,0 +1,15 @@ +use strict; +use warnings; + +use Test::More tests => 3; + +use List::Util qw( sum0 ); + +my $v = sum0; +is( $v, 0, 'no args' ); + +$v = sum0(9); +is( $v, 9, 'one arg' ); + +$v = sum0(1,2,3,4); +is( $v, 10, '4 args'); diff --git a/cpan/Scalar-List-Utils/t/tainted.t b/cpan/Scalar-List-Utils/t/tainted.t new file mode 100644 index 0000000000..8666117fe4 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/tainted.t @@ -0,0 +1,43 @@ +#!./perl -T + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } + elsif(!grep {/blib/} @INC) { + unshift(@INC, qw(./inc ./blib/arch ./blib/lib)); + } +} + +use Test::More tests => 5; + +use Scalar::Util qw(tainted); + +ok( !tainted(1), 'constant number'); + +my $var = 2; + +ok( !tainted($var), 'known variable'); + +my $key = (grep { !/^PERL/ } keys %ENV)[0]; + +ok( tainted($ENV{$key}), 'environment variable'); + +$var = $ENV{$key}; +ok( tainted($var), 'copy of environment variable'); + +{ + package Tainted; + sub TIESCALAR { bless {} } + sub FETCH { $^X } +} + +tie my $tiedvar, 'Tainted'; +ok( tainted($tiedvar), 'for magic variables'); diff --git a/cpan/Scalar-List-Utils/t/weak.t b/cpan/Scalar-List-Utils/t/weak.t new file mode 100644 index 0000000000..f014113694 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/weak.t @@ -0,0 +1,208 @@ +#!./perl + +use strict; +use Config; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Scalar::Util (); +use Test::More ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE}) + ? (skip_all => 'weaken requires XS version') + : (tests => 22); + +if (0) { + require Devel::Peek; + Devel::Peek->import('Dump'); +} +else { + *Dump = sub {}; +} + +Scalar::Util->import(qw(weaken isweak)); + +if(1) { + +my ($y,$z); + +# +# Case 1: two references, one is weakened, the other is then undef'ed. +# + +{ + my $x = "foo"; + $y = \$x; + $z = \$x; +} +print "# START\n"; +Dump($y); Dump($z); + +ok( ref($y) and ref($z)); + +print "# WEAK:\n"; +weaken($y); +Dump($y); Dump($z); + +ok( ref($y) and ref($z)); + +print "# UNDZ:\n"; +undef($z); +Dump($y); Dump($z); + +ok( not (defined($y) and defined($z)) ); + +print "# UNDY:\n"; +undef($y); +Dump($y); Dump($z); + +ok( not (defined($y) and defined($z)) ); + +print "# FIN:\n"; +Dump($y); Dump($z); + + +# +# Case 2: one reference, which is weakened +# + +print "# CASE 2:\n"; + +{ + my $x = "foo"; + $y = \$x; +} + +ok( ref($y) ); +print "# BW: \n"; +Dump($y); +weaken($y); +print "# AW: \n"; +Dump($y); +ok( not defined $y ); + +print "# EXITBLOCK\n"; +} + +# +# Case 3: a circular structure +# + +my $flag = 0; +{ + my $y = bless {}, 'Dest'; + Dump($y); + print "# 1: $y\n"; + $y->{Self} = $y; + Dump($y); + print "# 2: $y\n"; + $y->{Flag} = \$flag; + print "# 3: $y\n"; + weaken($y->{Self}); + print "# WKED\n"; + ok( ref($y) ); + print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y, + " FLAG: ",\$y->{Flag},"\n"; + print "# VPRINT\n"; +} +print "# OUT $flag\n"; +ok( $flag == 1 ); + +print "# AFTER\n"; + +undef $flag; + +print "# FLAGU\n"; + +# +# Case 4: a more complicated circular structure +# + +$flag = 0; +{ + my $y = bless {}, 'Dest'; + my $x = bless {}, 'Dest'; + $x->{Ref} = $y; + $y->{Ref} = $x; + $x->{Flag} = \$flag; + $y->{Flag} = \$flag; + weaken($x->{Ref}); +} +ok( $flag == 2 ); + +# +# Case 5: deleting a weakref before the other one +# + +my ($y,$z); +{ + my $x = "foo"; + $y = \$x; + $z = \$x; +} + +print "# CASE5\n"; +Dump($y); + +weaken($y); +Dump($y); +undef($y); + +ok( not defined $y); +ok( ref($z) ); + + +# +# Case 6: test isweakref +# + +$a = 5; +ok(!isweak($a)); +$b = \$a; +ok(!isweak($b)); +weaken($b); +ok(isweak($b)); +$b = \$a; +ok(!isweak($b)); + +my $x = {}; +weaken($x->{Y} = \$a); +ok(isweak($x->{Y})); +ok(!isweak($x->{Z})); + +# +# Case 7: test weaken on a read only ref +# + +SKIP: { + # Doesn't work for older perls, see bug [perl #24506] + skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003; + + # in a MAD build, constants have refcnt 2, not 1 + skip("Test does not work with MAD", 5) if exists $Config{mad}; + + $a = eval '\"hello"'; + ok(ref($a)) or print "# didn't get a ref from eval\n"; + $b = $a; + eval{weaken($b)}; + # we didn't die + ok($@ eq "") or print "# died with $@\n"; + ok(isweak($b)); + ok($$b eq "hello") or print "# b is '$$b'\n"; + $a=""; + ok(not $b) or print "# b didn't go away\n"; +} + +package Dest; + +sub DESTROY { + print "# INCFLAG\n"; + ${$_[0]{Flag}} ++; +} |