diff options
| author | Steve Hay <steve.m.hay@googlemail.com> | 2013-10-24 18:09:14 +0100 |
|---|---|---|
| committer | Steve Hay <steve.m.hay@googlemail.com> | 2013-10-24 18:09:14 +0100 |
| commit | cb8c84586a7e77e1b9100e6d88a6a9d18041ae96 (patch) | |
| tree | f6a0ebbe9f044f2eb27b0dc48936103198ca8b60 /cpan/List-Util | |
| parent | 41e70615a0bf7f35048f8163e68f1b9936509b9a (diff) | |
| download | perl-cb8c84586a7e77e1b9100e6d88a6a9d18041ae96.tar.gz | |
Move Cwd and List-Util to folders named as per their CPAN distributions
Diffstat (limited to 'cpan/List-Util')
33 files changed, 0 insertions, 3931 deletions
diff --git a/cpan/List-Util/ListUtil.xs b/cpan/List-Util/ListUtil.xs deleted file mode 100644 index 96c6d2b055..0000000000 --- a/cpan/List-Util/ListUtil.xs +++ /dev/null @@ -1,1077 +0,0 @@ -/* 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/List-Util/Makefile.PL b/cpan/List-Util/Makefile.PL deleted file mode 100644 index 5068e34598..0000000000 --- a/cpan/List-Util/Makefile.PL +++ /dev/null @@ -1,46 +0,0 @@ -# -*- 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/List-Util/lib/List/Util.pm b/cpan/List-Util/lib/List/Util.pm deleted file mode 100644 index 452dd2921f..0000000000 --- a/cpan/List-Util/lib/List/Util.pm +++ /dev/null @@ -1,353 +0,0 @@ -# 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/List-Util/lib/List/Util/XS.pm b/cpan/List-Util/lib/List/Util/XS.pm deleted file mode 100644 index 0625a0ae64..0000000000 --- a/cpan/List-Util/lib/List/Util/XS.pm +++ /dev/null @@ -1,41 +0,0 @@ -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/List-Util/lib/Scalar/Util.pm b/cpan/List-Util/lib/Scalar/Util.pm deleted file mode 100644 index edcaf1cb5b..0000000000 --- a/cpan/List-Util/lib/Scalar/Util.pm +++ /dev/null @@ -1,305 +0,0 @@ -# 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/List-Util/multicall.h b/cpan/List-Util/multicall.h deleted file mode 100644 index b8296e1755..0000000000 --- a/cpan/List-Util/multicall.h +++ /dev/null @@ -1,166 +0,0 @@ -/* 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/List-Util/t/00version.t b/cpan/List-Util/t/00version.t deleted file mode 100644 index d475de488d..0000000000 --- a/cpan/List-Util/t/00version.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./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/List-Util/t/any-all.t b/cpan/List-Util/t/any-all.t deleted file mode 100644 index 6fbf89a6ec..0000000000 --- a/cpan/List-Util/t/any-all.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./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/List-Util/t/blessed.t b/cpan/List-Util/t/blessed.t deleted file mode 100644 index ae292b9954..0000000000 --- a/cpan/List-Util/t/blessed.t +++ /dev/null @@ -1,55 +0,0 @@ -#!./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/List-Util/t/dualvar.t b/cpan/List-Util/t/dualvar.t deleted file mode 100644 index 0943c75545..0000000000 --- a/cpan/List-Util/t/dualvar.t +++ /dev/null @@ -1,142 +0,0 @@ -#!./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/List-Util/t/first.t b/cpan/List-Util/t/first.t deleted file mode 100644 index 497cdd5188..0000000000 --- a/cpan/List-Util/t/first.t +++ /dev/null @@ -1,134 +0,0 @@ -#!./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/List-Util/t/getmagic-once.t b/cpan/List-Util/t/getmagic-once.t deleted file mode 100644 index 00b3490783..0000000000 --- a/cpan/List-Util/t/getmagic-once.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./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/List-Util/t/isvstring.t b/cpan/List-Util/t/isvstring.t deleted file mode 100644 index 860113e067..0000000000 --- a/cpan/List-Util/t/isvstring.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./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/List-Util/t/lln.t b/cpan/List-Util/t/lln.t deleted file mode 100644 index 1499cdb49d..0000000000 --- a/cpan/List-Util/t/lln.t +++ /dev/null @@ -1,48 +0,0 @@ -#!/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/List-Util/t/max.t b/cpan/List-Util/t/max.t deleted file mode 100644 index 9607015d83..0000000000 --- a/cpan/List-Util/t/max.t +++ /dev/null @@ -1,76 +0,0 @@ -#!./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/List-Util/t/maxstr.t b/cpan/List-Util/t/maxstr.t deleted file mode 100644 index 11d98ff558..0000000000 --- a/cpan/List-Util/t/maxstr.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./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/List-Util/t/min.t b/cpan/List-Util/t/min.t deleted file mode 100644 index 8d5be5e153..0000000000 --- a/cpan/List-Util/t/min.t +++ /dev/null @@ -1,75 +0,0 @@ -#!./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/List-Util/t/minstr.t b/cpan/List-Util/t/minstr.t deleted file mode 100644 index 021b309dad..0000000000 --- a/cpan/List-Util/t/minstr.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./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/List-Util/t/multicall-refcount.t b/cpan/List-Util/t/multicall-refcount.t deleted file mode 100644 index 1d6fb59808..0000000000 --- a/cpan/List-Util/t/multicall-refcount.t +++ /dev/null @@ -1,21 +0,0 @@ -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/List-Util/t/openhan.t b/cpan/List-Util/t/openhan.t deleted file mode 100644 index e0dffb6f53..0000000000 --- a/cpan/List-Util/t/openhan.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./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/List-Util/t/pair.t b/cpan/List-Util/t/pair.t deleted file mode 100644 index 46e05342ac..0000000000 --- a/cpan/List-Util/t/pair.t +++ /dev/null @@ -1,97 +0,0 @@ -#!./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/List-Util/t/product.t b/cpan/List-Util/t/product.t deleted file mode 100644 index bed20cf8a5..0000000000 --- a/cpan/List-Util/t/product.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./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/List-Util/t/proto.t b/cpan/List-Util/t/proto.t deleted file mode 100644 index 50e401b59e..0000000000 --- a/cpan/List-Util/t/proto.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./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/List-Util/t/readonly.t b/cpan/List-Util/t/readonly.t deleted file mode 100644 index 91385fd18f..0000000000 --- a/cpan/List-Util/t/readonly.t +++ /dev/null @@ -1,53 +0,0 @@ -#!./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/List-Util/t/reduce.t b/cpan/List-Util/t/reduce.t deleted file mode 100644 index 4468ab8611..0000000000 --- a/cpan/List-Util/t/reduce.t +++ /dev/null @@ -1,169 +0,0 @@ -#!./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/List-Util/t/refaddr.t b/cpan/List-Util/t/refaddr.t deleted file mode 100644 index 35ad40f620..0000000000 --- a/cpan/List-Util/t/refaddr.t +++ /dev/null @@ -1,111 +0,0 @@ -#!./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/List-Util/t/reftype.t b/cpan/List-Util/t/reftype.t deleted file mode 100644 index 31a5d3b841..0000000000 --- a/cpan/List-Util/t/reftype.t +++ /dev/null @@ -1,65 +0,0 @@ -#!./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/List-Util/t/shuffle.t b/cpan/List-Util/t/shuffle.t deleted file mode 100644 index d3fbd6cd1f..0000000000 --- a/cpan/List-Util/t/shuffle.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./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/List-Util/t/stack-corruption.t b/cpan/List-Util/t/stack-corruption.t deleted file mode 100644 index dff5af03c4..0000000000 --- a/cpan/List-Util/t/stack-corruption.t +++ /dev/null @@ -1,30 +0,0 @@ -#!./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/List-Util/t/sum.t b/cpan/List-Util/t/sum.t deleted file mode 100644 index 3615b4ab41..0000000000 --- a/cpan/List-Util/t/sum.t +++ /dev/null @@ -1,97 +0,0 @@ -#!./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/List-Util/t/sum0.t b/cpan/List-Util/t/sum0.t deleted file mode 100644 index e76f8a79d3..0000000000 --- a/cpan/List-Util/t/sum0.t +++ /dev/null @@ -1,15 +0,0 @@ -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/List-Util/t/tainted.t b/cpan/List-Util/t/tainted.t deleted file mode 100644 index 8666117fe4..0000000000 --- a/cpan/List-Util/t/tainted.t +++ /dev/null @@ -1,43 +0,0 @@ -#!./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/List-Util/t/weak.t b/cpan/List-Util/t/weak.t deleted file mode 100644 index f014113694..0000000000 --- a/cpan/List-Util/t/weak.t +++ /dev/null @@ -1,208 +0,0 @@ -#!./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}} ++; -} |