diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-02-09 16:20:28 +0000 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-02-09 16:20:28 +0000 |
| commit | e505b8249ffa50fff52b65da8e9069b8fc1bdee8 (patch) | |
| tree | ccf7ff79034a221050c5a424d92c63793979a0b9 /ext/List-Util | |
| parent | 2c864a0811fbe4cad763045a119f93a241340a2f (diff) | |
| download | perl-e505b8249ffa50fff52b65da8e9069b8fc1bdee8.tar.gz | |
Rename ext/List/Util as ext/List-Util
Diffstat (limited to 'ext/List-Util')
42 files changed, 3065 insertions, 0 deletions
diff --git a/ext/List-Util/Changes b/ext/List-Util/Changes new file mode 100644 index 0000000000..74c0f85aa5 --- /dev/null +++ b/ext/List-Util/Changes @@ -0,0 +1,350 @@ +1.19 -- Sun Dec 10 09:58:03 CST 2006 + +Bug Fixes + * Fix invalid conversion from `const char*' to `char*' warnings + * Avoid Makefile error when building on Win32 + * Fix undefined symbol error for perl < 5.9.0 + * Fix hardcoded "/" in a filepath that causes p_tainted.t to fail on VMS + +Documentation + * Document that reduce calls BLOCK in a scalar context + * Add SEE ALSO sections to docs + +Enhancements + * A new regression test for readonly, taking a reference to a constant passed to a sub + +1.18 -- Fri Nov 25 09:30:29 CST 2005 + +Bug Fixes + * Fix pure-perl version of refaddr to avoid blessing an un-blessed reference + * Fix memory leak in first() and reduce() + * Pure perl version of looks_like_number now matches XS version for + references and undef. It will now return undef + +Enhancements + * Support for using XSLoader instead of DynaLoader + * Use new multicall API + +1.17 -- Mon May 23 08:55:26 CDT 2005 + +Bug Fixes + * Update XS code to declare PERL_UNUSED_DECL conditionally + +1.16 -- Fri May 20 10:22:49 CDT 2005 + +Bug Fixes + * Change to refaddr.t test to avoid false errors on some 64 bit platforms + * Fix all perl only tests to work when in the core build environment + * Fix looks like number test to work for 5.8.5 and above + +1.15 -- Fri May 13 11:01:15 CDT 2005 + +Bug Fixes + * Fixed memory leak in first() + +Enhancements + * Converted tests to use Test::More + * Improved test coverage + * Changed Makefile.PL to use Module::Install + * Refactor use of Sv..X() macros to be Sv.._set() + * Changes from Jarkko for Symbian port of Perl + * Documentation updates to weaken() + +1.14 -- Sat May 22 08:01:19 BST 2004 + +Bug Fixes + * Fixed memory leak in reduce() + * Added tests to check passing a reference to a constant to weaken() in perl >= 5.008003 + * Fixed looks_like_number(undef) to return false for perl >= 5.009002 + * Fixed bug in refaddr() when passed a tied variable + +Switch to svn repository at http://svn.mutatus.co.uk/wsvn/Scalar-List-Utils/trunk/ +Old perforce revision log below + +Change 827 on 2003/09/25 by <gbarr@pobox.com> (Graham Barr) + + Release 1.13 + +Change 826 on 2003/09/25 by <gbarr@pobox.com> (Graham Barr) + + Fix NV casting issue with some compilers + +Change 825 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr) + + Release 1.12 + +Change 824 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr) + + Don't directly use the SV returned as $a in the next iteration, + take a copy instead. Fixes problem if the code block result was from + an eval or sub call + +Change 823 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr) + + Install into the 'perl' installdirs for >= 5.008 + +Change 822 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr) + + Fix test for EBCDIC portability + +Change 771 on 2003/03/03 by <gbarr@pobox.com> (Graham Barr) + + Get path for make from $Config + +Change 770 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr) + + Release 1.11 + +Change 769 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr) + + Add t/proto.t to MANIFEST + +Change 768 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr) + + Add set_prototype from Rafael Garcia-Suarez + +Change 767 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr) + + Fix t/isvstring.t so it does not cause perl5.004 to segv + because of the exit from within BEGIN + +Change 766 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr) + + Change how patchlevel.h is included and check we got what we wanted (from Jarkko) + +Change 765 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr) + + Add -DPERL_EXT to DEFINEs, requested by Jarkko for 5.8.1 + +Change 764 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr) + + Release 1.10 + +Change 763 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr) + + Fix linking error for older perls + +Change 762 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr) + + Make lln tests and perl implementation mimic changes to looks_like_number + in different perl versions + +Change 761 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr) + + Add looks_like_number + +Change 760 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr) + + Ensure PERL_DL_NONLAZY is false so we don't catch link errors during + bootstrap and then test the perl only version + +Change 759 on 2002/12/12 by <gbarr@pobox.com> (Graham Barr) + + Release 1.09 + +Change 758 on 2002/12/12 by <gbarr@pobox.com> (Graham Barr) + + Use UV to return refaddr + +Change 757 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr) + + Add XS_VERSION + +Change 756 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr) + + Use PAD_* macros in 5.9 + Reuse our own target when calling pp_rand in shuffle() so we dont need to create a fake pad + +Change 751 on 2002/10/18 by <gbarr@pobox.com> (Graham Barr) + + Fix context so that sub for reduce/first is always in a scalar context + Fix sum/min/max so that they don't upgrade their arguments to NVs + if they are IV or UV + +Change 750 on 2002/10/14 by <gbarr@pobox.com> (Graham Barr) + + Add isvstring() + +Change 745 on 2002/09/23 by <gbarr@pobox.com> (Graham Barr) + + Scalar::Util + - Add refaddr() + +Change 722 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr) + + Release 1.0701 + +Change 721 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr) + + Add comment to README about failing tests on perl5.6.0 + +Change 714 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr) + + Release 1.07 + +Change 713 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr) + + Add Scalar::Util::openhandle() + +Change 647 on 2001/09/18 by <gbarr@pobox.com> (Graham Barr) + + Release 1.06 + +Change 645 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr) + + Some platforms require the main executable to export symbols + needed by modules. In 5.7.2 and prior releases of perl + Perl_cxinc was not exported so we need to duplicate its + functionality + +Change 644 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr) + + Generate a typemap for NV for all perl version up to and + including 5.006 + +Change 643 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr) + + Document problems known with specific versions of perl + +Change 642 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr) + + Release 1.05 + +Change 641 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr) + + Fix shuffle() to compile with threaded perl + +Change 640 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr) + + Release 1.04 + +Change 639 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr) + + Fix context type (caused a core on Tru64) + Call pp_rand via *(PL_ppaddr[OP_RAND]) + +Change 638 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr) + + Documentation updates + +Change 637 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr) + + Release 1.03 + +Change 636 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr) + + More changes to help merging with core dist + +Change 635 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr) + + Added List::Util::shuffle() similar to that described in + the perl FAQ except it returns a shuffled list instead of + modifying an array passed by reference + +Change 632 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr) + + Handle tied variables passed for the number to dualvar() + Preserve number type (IV/UV/NV) in dualvar() + +Change 631 on 2001/08/31 by <gbarr@pobox.com> (Graham Barr) + + Handle eval{} inside of the code blocks for first and reduce + +Change 629 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr) + + perl5.004 does not like exit from within a BEGIN, it core dumps + +Change 628 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr) + + Fix stack problem in first() and reduce() + Align with core dist + +Change 483 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr) + + Release 1.02 + +Change 482 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr) + + Check for SvMAGICAL on argument for reftype and blessed + +Change 366 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr) + + Release 1.01 + +Change 365 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr) + + - Added auto-detection for a compiler and install the perl version + if not found + - Better perl implemenation of reftype, should be thread-safe now + +Change 364 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr) + + - Added some examples of simple subs that have been requested + but not added + - Updated copyright dates + +Change 344 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr) + + - Better testcase for reftype + +Change 343 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr) + + - Modules are now called List::Util & Scalar::Util + - Supports non-XS install + - perl version of reftype now returns "REF" when it should + +Change 311 on 1999/06/01 by <gbarr@pobox.com> (Graham Barr) + + Updated README + +Change 275 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr) + + Removed forall as it is very broken + +Change 274 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr) + + Added List::Util::forall + +Change 273 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr) + + Added weaken and isweak to Ref::Util + +Change 272 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr) + + Add new .pm files to repository + +Change 271 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr) + + - Split into three packages Ref::Util, List::Util and Scalar::DualVar + - readonly and clock were removed in favor of other modules + +Change 270 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr) + + Rename package + +Change 269 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr) + + - Added reftype + - improved reduce by not doing a sub call + - reduce now uses $a and $b + - now compiles with 5.005_5x + +Change 178 on 1998/07/26 by <gbarr@pobox.com> (Graham Barr) + + Modified XS code so it will compile with 5.004 and 5.005 + +Change 115 on 1998/02/21 by <gbarr@pobox.com> (Graham Barr) + + Fri Feb 20 1998 Graham Barr <gbarr@pobox.com> + + t/min.t, t/max.t + - Change sor to do a numerical sort + + Fri Dec 19 1997 Graham Barr <gbarr@pobox.com> + + - Added readonly() + + Wed Nov 19 1997 Graham Barr <gbarr@pobox.com> + + - Initial release + diff --git a/ext/List-Util/Makefile.PL b/ext/List-Util/Makefile.PL new file mode 100644 index 0000000000..48dccdb91d --- /dev/null +++ b/ext/List-Util/Makefile.PL @@ -0,0 +1,47 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + VERSION_FROM => "lib/List/Util.pm", + MAN3PODS => {}, # Pods will be built by installman. + NAME => "List::Util", + DEFINE => "-DPERL_EXT", +); + +package MY; + +# We go through the ListUtil.c 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. + +BEGIN { + use Config; + unless (defined $Config{usedl}) { + eval <<'__EOMM__'; +sub xs_c { + my($self) = shift; + return '' unless $self->needs_linking(); +' +ListUtil.c: Util.xs + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) Util.xs > ListUtil.xsc && $(MV) ListUtil.xsc ListUtil.c +'; +} + +sub xs_o { + my($self) = shift; + return '' unless $self->needs_linking(); +' + +Util$(OBJ_EXT): ListUtil.c + $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) ListUtil.c + $(MV) ListUtil$(OBJ_EXT) Util$(OBJ_EXT) +'; +} + +__EOMM__ + } +} diff --git a/ext/List-Util/README b/ext/List-Util/README new file mode 100644 index 0000000000..4fa789eb52 --- /dev/null +++ b/ext/List-Util/README @@ -0,0 +1,23 @@ +This distribution is a replacement for the builtin distribution. + +This package 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. + +After unpacking the distribution, to install this module type + + perl Makefile.PL + make + make test + make install + +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 + + +Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved. +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. diff --git a/ext/List-Util/Util.xs b/ext/List-Util/Util.xs new file mode 100644 index 0000000000..585225c5b3 --- /dev/null +++ b/ext/List-Util/Util.xs @@ -0,0 +1,559 @@ +/* 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. + */ + +#include <EXTERN.h> +#include <perl.h> +#include <XSUB.h> + +#ifndef PERL_VERSION +# include <patchlevel.h> +# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# define PERL_REVISION 5 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION +#endif + +#if PERL_VERSION >= 6 +# include "multicall.h" +#endif + +#ifndef aTHX +# define aTHX +# define pTHX +#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_VERSION < 7 +/* Not in 5.6.1. */ +# define SvUOK(sv) SvIOK_UV(sv) +# 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); /* XXX should fix CXINC macro */ + return cxstack_ix + 1; +} +#endif + +#if PERL_VERSION < 6 +# define NV double +#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 + +#ifndef Drand01 +# define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) +#endif + +#if PERL_VERSION < 5 +# ifndef gv_stashpvn +# define gv_stashpvn(n,l,c) gv_stashpv(n,c) +# endif +# ifndef SvTAINTED + +static bool +sv_tainted(SV *sv) +{ + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + MAGIC *mg = mg_find(sv, 't'); + if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) + return TRUE; + } + return FALSE; +} + +# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0) +# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv)) +# endif +# define PL_defgv defgv +# define PL_op op +# define PL_curpad curpad +# define CALLRUNOPS runops +# define PL_curpm curpm +# define PL_sv_undef sv_undef +# define PERL_CONTEXT struct context +#endif +#if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50) +# ifndef PL_tainting +# define PL_tainting tainting +# endif +# ifndef PL_stack_base +# define PL_stack_base stack_base +# endif +# ifndef PL_stack_sp +# define PL_stack_sp stack_sp +# endif +# ifndef PL_ppaddr +# define PL_ppaddr ppaddr +# endif +#endif + +#ifndef PTR2UV +# define PTR2UV(ptr) (UV)(ptr) +#endif + +#ifndef SvUV_set +# define SvUV_set(sv, val) (((XPVUV*)SvANY(sv))->xuv_uv = (val)) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef dNOOP +#define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef dVAR +#define dVAR dNOOP +#endif + +#ifndef GvSVn +# define GvSVn GvSV +#endif + +MODULE=List::Util PACKAGE=List::Util + +void +min(...) +PROTOTYPE: @ +ALIAS: + min = 0 + max = 1 +CODE: +{ + int index; + NV retval; + SV *retsv; + if(!items) { + XSRETURN_UNDEF; + } + retsv = ST(0); + retval = slu_sv_value(retsv); + for(index = 1 ; index < items ; index++) { + SV *stacksv = ST(index); + NV val = slu_sv_value(stacksv); + if(val < retval ? !ix : ix) { + retsv = stacksv; + retval = val; + } + } + ST(0) = retsv; + XSRETURN(1); +} + + + +NV +sum(...) +PROTOTYPE: @ +CODE: +{ + SV *sv; + int index; + if(!items) { + XSRETURN_UNDEF; + } + sv = ST(0); + RETVAL = slu_sv_value(sv); + for(index = 1 ; index < items ; index++) { + sv = ST(index); + RETVAL += slu_sv_value(sv); + } +} +OUTPUT: + RETVAL + + +void +minstr(...) +PROTOTYPE: @ +ALIAS: + minstr = 2 + maxstr = 0 +CODE: +{ + SV *left; + int index; + if(!items) { + XSRETURN_UNDEF; + } + /* + sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt + so we set ix to the value we are looking for + xsubpp does not allow -ve values, so we start with 0,2 and subtract 1 + */ + ix -= 1; + 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); +} + + + +#ifdef dMULTICALL + +void +reduce(block,...) + SV * block +PROTOTYPE: &@ +CODE: +{ + dVAR; dMULTICALL; + SV *ret = sv_newmortal(); + int index; + GV *agv,*bgv,*gv; + HV *stash; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *cv; + + if(items <= 1) { + XSRETURN_UNDEF; + } + cv = sv_2cv(block, &stash, &gv, 0); + PUSH_MULTICALL(cv); + agv = gv_fetchpv("a", TRUE, SVt_PV); + bgv = gv_fetchpv("b", TRUE, SVt_PV); + SAVESPTR(GvSV(agv)); + SAVESPTR(GvSV(bgv)); + GvSV(agv) = ret; + SvSetSV(ret, args[1]); + for(index = 2 ; index < items ; index++) { + GvSV(bgv) = args[index]; + MULTICALL; + SvSetSV(ret, *PL_stack_sp); + } + POP_MULTICALL; + ST(0) = ret; + XSRETURN(1); +} + +void +first(block,...) + SV * block +PROTOTYPE: &@ +CODE: +{ + dVAR; dMULTICALL; + int index; + GV *gv; + HV *stash; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *cv; + + if(items <= 1) { + XSRETURN_UNDEF; + } + cv = sv_2cv(block, &stash, &gv, 0); + PUSH_MULTICALL(cv); + SAVESPTR(GvSV(PL_defgv)); + + for(index = 1 ; index < items ; index++) { + GvSV(PL_defgv) = args[index]; + MULTICALL; + if (SvTRUE(*PL_stack_sp)) { + POP_MULTICALL; + ST(0) = ST(index); + XSRETURN(1); + } + } + POP_MULTICALL; + XSRETURN_UNDEF; +} + +#endif + +void +shuffle(...) +PROTOTYPE: @ +CODE: +{ + dVAR; + 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: +{ + STRLEN len; + char *ptr = SvPV(str,len); + ST(0) = sv_newmortal(); + (void)SvUPGRADE(ST(0),SVt_PVNV); + sv_setpvn(ST(0),ptr,len); + if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { + SvNV_set(ST(0), SvNV(num)); + SvNOK_on(ST(0)); + } +#ifdef SVf_IVisUV + else if (SvUOK(num)) { + SvUV_set(ST(0), SvUV(num)); + SvIOK_on(ST(0)); + SvIsUV_on(ST(0)); + } +#endif + else { + SvIV_set(ST(0), SvIV(num)); + SvIOK_on(ST(0)); + } + if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) + SvTAINTED_on(ST(0)); + XSRETURN(1); +} + +char * +blessed(sv) + SV * sv +PROTOTYPE: $ +CODE: +{ + if (SvMAGICAL(sv)) + mg_get(sv); + if(!sv_isobject(sv)) { + XSRETURN_UNDEF; + } + RETVAL = (char*)sv_reftype(SvRV(sv),TRUE); +} +OUTPUT: + RETVAL + +char * +reftype(sv) + SV * sv +PROTOTYPE: $ +CODE: +{ + if (SvMAGICAL(sv)) + mg_get(sv); + if(!SvROK(sv)) { + XSRETURN_UNDEF; + } + RETVAL = (char*)sv_reftype(SvRV(sv),FALSE); +} +OUTPUT: + RETVAL + +UV +refaddr(sv) + SV * sv +PROTOTYPE: $ +CODE: +{ + if (SvMAGICAL(sv)) + mg_get(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: + RETVAL = SvREADONLY(sv); +OUTPUT: + RETVAL + +int +tainted(sv) + SV *sv +PROTOTYPE: $ +CODE: + RETVAL = SvTAINTED(sv); +OUTPUT: + RETVAL + +void +isvstring(sv) + SV *sv +PROTOTYPE: $ +CODE: +#ifdef SvVOK + 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: +#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5) + 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 */ + STRLEN len; + char *ptr = SvPV(proto, len); + sv_setpvn(sv, ptr, len); + } + else { + /* delete the prototype */ + SvPOK_off(sv); + } + } + else { + croak("set_prototype: not a reference"); + } + XSRETURN(1); +} + +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", 12, 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/ext/List-Util/lib/List/Util.pm b/ext/List-Util/lib/List/Util.pm new file mode 100644 index 0000000000..829148c056 --- /dev/null +++ b/ext/List-Util/lib/List/Util.pm @@ -0,0 +1,281 @@ +# List::Util.pm +# +# Copyright (c) 1997-2006 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. + +package List::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); +require Exporter; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); +$VERSION = "1.19"; +$XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +eval { + # PERL_DL_NONLAZY must be false, or any errors in loading will just + # cause the perl code to be tested + local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; + eval { + require XSLoader; + XSLoader::load('List::Util', $XS_VERSION); + 1; + } or do { + require DynaLoader; + local @ISA = qw(DynaLoader); + bootstrap List::Util $XS_VERSION; + }; +} unless $TESTING_PERL_ONLY; + + +# This code is only compiled if the XS did not load +# of for perl < 5.6.0 + +if (!defined &reduce) { +eval <<'ESQ' + +sub reduce (&@) { + my $code = shift; + no strict 'refs'; + + return shift unless @_ > 1; + + use vars qw($a $b); + + my $caller = caller; + local(*{$caller."::a"}) = \my $a; + local(*{$caller."::b"}) = \my $b; + + $a = shift; + foreach (@_) { + $b = $_; + $a = &{$code}(); + } + + $a; +} + +sub first (&@) { + my $code = shift; + + foreach (@_) { + return $_ if &{$code}(); + } + + undef; +} + +ESQ +} + +# This code is only compiled if the XS did not load +eval <<'ESQ' if !defined ∑ + +use vars qw($a $b); + +sub sum (@) { reduce { $a + $b } @_ } + +sub min (@) { reduce { $a < $b ? $a : $b } @_ } + +sub max (@) { reduce { $a > $b ? $a : $b } @_ } + +sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } + +sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } + +sub shuffle (@) { + my @a=\(@_); + my $n; + my $i=@_; + map { + $n = rand($i--); + (${$a[$n]}, $a[$n] = $a[$i])[0]; + } @_; +} + +ESQ + +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. The +subroutines defined are + +=over 4 + +=item 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 + +This function could be implemented using C<reduce> like this + + $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list + +for example wanted() could be defined() which would return the first +defined value in @list + +=item 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 + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a > $b ? $a : $b } 1..10 + +=item 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 + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' + +=item 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 + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a < $b ? $a : $b } 1..10 + +=item 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 + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z' + +=item 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. + + $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 + +=item shuffle LIST + +Returns the elements of LIST in a random order + + @cards = shuffle 0..51 # 0..51 in a random order + +=item 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 + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a + $b } 1..10 + +=back + +=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 + + # One argument is true + + sub any { $_ && return 1 for @_; 0 } + + # All arguments are true + + sub all { $_ || return 0 for @_; 1 } + + # All arguments are false + + sub none { $_ && return 0 for @_; 1 } + + # One argument is false + + sub notall { $_ || return 1 for @_; 0 } + + # 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-2006 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/ext/List-Util/lib/Scalar/Util.pm b/ext/List-Util/lib/Scalar/Util.pm new file mode 100644 index 0000000000..f947f741e7 --- /dev/null +++ b/ext/List-Util/lib/Scalar/Util.pm @@ -0,0 +1,334 @@ +# Scalar::Util.pm +# +# Copyright (c) 1997-2006 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. + +package Scalar::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION); +require Exporter; +require List::Util; # List::Util loads the XS + +@ISA = qw(Exporter); +@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); +$VERSION = "1.19"; +$VERSION = eval $VERSION; + +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"); + } + if (grep { /^(dualvar|set_prototype)$/ } @_ ) { + require Carp; + Carp::croak("$1 is only avaliable with the XS version"); + } + + @_; +} + +sub openhandle ($) { + my $fh = shift; + my $rt = reftype($fh) || ''; + + return defined(fileno($fh)) ? $fh : undef + if $rt eq 'IO'; + + if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) + $fh = \(my $tmp=$fh); + } + elsif ($rt ne 'GLOB') { + return undef; + } + + (tied(*$fh) or defined(fileno($fh))) + ? $fh : undef; +} + +eval <<'ESQ' unless defined &dualvar; + +use vars qw(@EXPORT_FAIL); +push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); + +# The code beyond here is only used if the XS is not installed + +# Hope nobody defines a sub by this name +sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) } + +sub blessed ($) { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + length(ref($_[0])) + ? eval { $_[0]->a_sub_not_likely_to_be_here } + : undef +} + +sub refaddr($) { + my $pkg = ref($_[0]) or return undef; + if (blessed($_[0])) { + bless $_[0], 'Scalar::Util::Fake'; + } + else { + $pkg = undef; + } + "$_[0]" =~ /0x(\w+)/; + my $i = do { local $^W; hex $1 }; + bless $_[0], $pkg if defined $pkg; + $i; +} + +sub reftype ($) { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + my $r = shift; + my $t; + + length($t = ref($r)) or return undef; + + # This eval will fail if the reference is not blessed + eval { $r->a_sub_not_likely_to_be_here; 1 } + ? do { + $t = eval { + # we have a GLOB or an IO. Stringify a GLOB gives it's name + my $q = *$r; + $q =~ /^\*/ ? "GLOB" : "IO"; + } + or do { + # OK, if we don't have a GLOB what parts of + # a glob will it populate. + # NOTE: A glob always has a SCALAR + local *glob = $r; + defined *glob{ARRAY} && "ARRAY" + or defined *glob{HASH} && "HASH" + or defined *glob{CODE} && "CODE" + or length(ref(${$r})) ? "REF" : "SCALAR"; + } + } + : $t +} + +sub tainted { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + local $^W = 0; + eval { kill 0 * $_[0] }; + $@ =~ /^Insecure/; +} + +sub readonly { + return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); + + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + my $tmp = $_[0]; + + !eval { $_[0] = $tmp; 1 }; +} + +sub looks_like_number { + local $_ = shift; + + # checks from perlfaq4 + return 0 if !defined($_) or ref($_); + return 1 if (/^[+-]?\d+$/); # is a +/- integer + return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float + return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); + + 0; +} + +ESQ + +1; + +__END__ + +=head1 NAME + +Scalar::Util - A selection of general-utility scalar subroutines + +=head1 SYNOPSIS + + use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted + weaken isvstring looks_like_number set_prototype); + +=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 + +=over 4 + +=item 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" + +=item 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 + +=item 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); + +=item 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($ref); # false + +=item looks_like_number EXPR + +Returns true if perl thinks EXPR is a number. See +L<perlapi/looks_like_number>. + +=item 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 + +=item readonly SCALAR + +Returns true if SCALAR is readonly. + + sub foo { readonly($_[0]) } + + $readonly = foo($bar); # false + $readonly = foo(0); # true + +=item 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 + +=item 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 + +=item set_prototype CODEREF, PROTOTYPE + +Sets the prototype of the given function, or deletes it if PROTOTYPE is +undef. Returns the CODEREF. + + set_prototype \&foo, '$$'; + +=item tainted EXPR + +Return true if the result of EXPR is tainted + + $taint = tainted("constant"); # false + $taint = tainted($ENV{PWD}); # true if running under -T + +=item 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. + +=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-2006 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/ext/List-Util/multicall.h b/ext/List-Util/multicall.h new file mode 100644 index 0000000000..b8296e1755 --- /dev/null +++ b/ext/List-Util/multicall.h @@ -0,0 +1,166 @@ +/* multicall.h (version 1.0) + * + * Implements a poor-man's MULTICALL interface for old versions + * of perl that don't offer a proper one. Intended to be compatible + * with 5.6.0 and later. + * + */ + +#ifdef dMULTICALL +#define REAL_MULTICALL +#else +#undef REAL_MULTICALL + +/* In versions of perl where MULTICALL is not defined (i.e. prior + * to 5.9.4), Perl_pad_push is not exported either. It also has + * an extra argument in older versions; certainly in the 5.8 series. + * So we redefine it here. + */ + +#ifndef AVf_REIFY +# ifdef SVpav_REIFY +# define AVf_REIFY SVpav_REIFY +# else +# error Neither AVf_REIFY nor SVpav_REIFY is defined +# endif +#endif + +#ifndef AvFLAGS +# define AvFLAGS SvFLAGS +#endif + +static void +multicall_pad_push(pTHX_ AV *padlist, int depth) +{ + if (depth <= AvFILLp(padlist)) + return; + + { + SV** const svp = AvARRAY(padlist); + AV* const newpad = newAV(); + SV** const oldpad = AvARRAY(svp[depth-1]); + I32 ix = AvFILLp((AV*)svp[1]); + const I32 names_fill = AvFILLp((AV*)svp[0]); + SV** const names = AvARRAY(svp[0]); + AV *av; + + for ( ;ix > 0; ix--) { + if (names_fill >= ix && names[ix] != &PL_sv_undef) { + const char sigil = SvPVX(names[ix])[0]; + if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') { + /* outer lexical or anon code */ + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { /* our own lexical */ + SV *sv; + if (sigil == '@') + sv = (SV*)newAV(); + else if (sigil == '%') + sv = (SV*)newHV(); + else + sv = NEWSV(0, 0); + av_store(newpad, ix, sv); + SvPADMY_on(sv); + } + } + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { + /* save temporaries on recursion? */ + SV * const sv = NEWSV(0, 0); + av_store(newpad, ix, sv); + SvPADTMP_on(sv); + } + } + av = newAV(); + av_extend(av, 0); + av_store(newpad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; + + av_store(padlist, depth, (SV*)newpad); + AvFILLp(padlist) = depth; + } +} + +#define dMULTICALL \ + SV **newsp; /* set by POPBLOCK */ \ + PERL_CONTEXT *cx; \ + CV *multicall_cv; \ + OP *multicall_cop; \ + bool multicall_oldcatch; \ + U8 hasargs = 0 + +/* Between 5.9.1 and 5.9.2 the retstack was removed, and the + return op is now stored on the cxstack. */ +#define HAS_RETSTACK (\ + PERL_REVISION < 5 || \ + (PERL_REVISION == 5 && PERL_VERSION < 9) || \ + (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \ +) + + +/* PUSHSUB is defined so differently on different versions of perl + * that it's easier to define our own version than code for all the + * different possibilities. + */ +#if HAS_RETSTACK +# define PUSHSUB_RETSTACK(cx) +#else +# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop; +#endif +#define MULTICALL_PUSHSUB(cx, the_cv) \ + cx->blk_sub.cv = the_cv; \ + cx->blk_sub.olddepth = CvDEPTH(the_cv); \ + cx->blk_sub.hasargs = hasargs; \ + cx->blk_sub.lval = PL_op->op_private & \ + (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \ + PUSHSUB_RETSTACK(cx) \ + if (!CvDEPTH(the_cv)) { \ + (void)SvREFCNT_inc(the_cv); \ + (void)SvREFCNT_inc(the_cv); \ + SAVEFREESV(the_cv); \ + } + +#define PUSH_MULTICALL(the_cv) \ + STMT_START { \ + CV *_nOnclAshIngNamE_ = the_cv; \ + AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \ + multicall_cv = _nOnclAshIngNamE_; \ + ENTER; \ + multicall_oldcatch = CATCH_GET; \ + SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \ + CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ + SAVETMPS; SAVEVPTR(PL_op); \ + CATCH_SET(TRUE); \ + PUSHSTACKi(PERLSI_SORT); \ + PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \ + MULTICALL_PUSHSUB(cx, multicall_cv); \ + if (++CvDEPTH(multicall_cv) >= 2) { \ + PERL_STACK_OVERFLOW_CHECK(); \ + multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \ + } \ + SAVECOMPPAD(); \ + PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \ + PL_curpad = AvARRAY(PL_comppad); \ + multicall_cop = CvSTART(multicall_cv); \ + } STMT_END + +#define MULTICALL \ + STMT_START { \ + PL_op = multicall_cop; \ + CALLRUNOPS(aTHX); \ + } STMT_END + +#define POP_MULTICALL \ + STMT_START { \ + CvDEPTH(multicall_cv)--; \ + LEAVESUB(multicall_cv); \ + POPBLOCK(cx,PL_curpm); \ + POPSTACK; \ + CATCH_SET(multicall_oldcatch); \ + LEAVE; \ + SPAGAIN; \ + } STMT_END + +#endif diff --git a/ext/List-Util/t/00version.t b/ext/List-Util/t/00version.t new file mode 100644 index 0000000000..fad6e0f380 --- /dev/null +++ b/ext/List-Util/t/00version.t @@ -0,0 +1,22 @@ +#!./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 Test::More tests => 1; + +is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch"); + + diff --git a/ext/List-Util/t/blessed.t b/ext/List-Util/t/blessed.t new file mode 100755 index 0000000000..8002404dbb --- /dev/null +++ b/ext/List-Util/t/blessed.t @@ -0,0 +1,31 @@ +#!./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 => 8; +use Scalar::Util qw(blessed); +use vars qw($t $x); + +ok(!blessed(undef), 'undef is not blessed'); +ok(!blessed(1), 'Numbers are not blessed'); +ok(!blessed('A'), 'Strings are not blessed'); +ok(!blessed({}), 'Unblessed HASH-ref'); +ok(!blessed([]), 'Unblessed ARRAY-ref'); +ok(!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'); diff --git a/ext/List-Util/t/dualvar.t b/ext/List-Util/t/dualvar.t new file mode 100755 index 0000000000..652f22ede9 --- /dev/null +++ b/ext/List-Util/t/dualvar.t @@ -0,0 +1,58 @@ +#!./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 => 11); + +Scalar::Util->import('dualvar'); + +$var = dualvar( 2.2,"string"); + +ok( $var == 2.2, 'Numeric value'); +ok( $var eq "string", 'String value'); + +$var2 = $var; + +ok( $var2 == 2.2, 'copy Numeric value'); +ok( $var2 eq "string", 'copy String value'); + +$var++; + +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( $var == $numstr, 'NV'); + +$var = dualvar(1<<31, ""); +ok( $var == (1<<31), 'UV 1'); +ok( $var > 0, 'UV 2'); + +tie my $tied, 'Tied'; +$var = dualvar($tied, "ok"); +ok($var == 7.5, 'Tied num'); +ok($var eq 'ok', 'Tied str'); + +package Tied; + +sub TIESCALAR { bless {} } +sub FETCH { 7.5 } + diff --git a/ext/List-Util/t/first.t b/ext/List-Util/t/first.t new file mode 100755 index 0000000000..07377ab340 --- /dev/null +++ b/ext/List-Util/t/first.t @@ -0,0 +1,115 @@ +#!./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 => ($::PERL_ONLY ? 15 : 17); +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"); + +} } diff --git a/ext/List-Util/t/isvstring.t b/ext/List-Util/t/isvstring.t new file mode 100644 index 0000000000..860113e067 --- /dev/null +++ b/ext/List-Util/t/isvstring.t @@ -0,0 +1,33 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +$|=1; +use Scalar::Util (); +use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) + ? (skip_all => 'isvstring requires XS version') + : (tests => 3); + +Scalar::Util->import(qw[isvstring]); + +$vs = ord("A") == 193 ? 241.75.240 : 49.46.48; + +ok( $vs == "1.0", 'dotted num'); +ok( isvstring($vs), 'isvstring'); + +$sv = "1.0"; +ok( !isvstring($sv), 'not isvstring'); + + + diff --git a/ext/List-Util/t/lln.t b/ext/List-Util/t/lln.t new file mode 100644 index 0000000000..4ec77199fc --- /dev/null +++ b/ext/List-Util/t/lln.t @@ -0,0 +1,37 @@ +#!/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 => 16; +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), '', 'Math::BigInt'); +is(!!looks_like_number("$bi"), 1, 'Stringified Math::BigInt'); + +# We should copy some of perl core tests like t/base/num.t here diff --git a/ext/List-Util/t/max.t b/ext/List-Util/t/max.t new file mode 100755 index 0000000000..dd25a13817 --- /dev/null +++ b/ext/List-Util/t/max.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 5; +use List::Util qw(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'); diff --git a/ext/List-Util/t/maxstr.t b/ext/List-Util/t/maxstr.t new file mode 100755 index 0000000000..11d98ff558 --- /dev/null +++ b/ext/List-Util/t/maxstr.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 5; +use List::Util qw(maxstr); + +my $v; + +ok(defined &maxstr, 'defined'); + +$v = maxstr('a'); +is($v, 'a', 'single arg'); + +$v = maxstr('a','b'); +is($v, 'b', '2-arg ordered'); + +$v = maxstr('B','A'); +is($v, 'B', '2-arg reverse ordered'); + +my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20; +my @b = sort { $a cmp $b } @a; +$v = maxstr(@a); +is($v, $b[-1], 'random ordered'); diff --git a/ext/List-Util/t/min.t b/ext/List-Util/t/min.t new file mode 100755 index 0000000000..5e8c234698 --- /dev/null +++ b/ext/List-Util/t/min.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 5; +use List::Util qw(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'); diff --git a/ext/List-Util/t/minstr.t b/ext/List-Util/t/minstr.t new file mode 100755 index 0000000000..021b309dad --- /dev/null +++ b/ext/List-Util/t/minstr.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More tests => 5; +use List::Util qw(minstr); + +my $v; + +ok(defined &minstr, 'defined'); + +$v = minstr('a'); +is($v, 'a', 'single arg'); + +$v = minstr('a','b'); +is($v, 'a', '2-arg ordered'); + +$v = minstr('B','A'); +is($v, 'A', '2-arg reverse ordered'); + +my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20; +my @b = sort { $a cmp $b } @a; +$v = minstr(@a); +is($v, $b[0], 'random ordered'); diff --git a/ext/List-Util/t/openhan.t b/ext/List-Util/t/openhan.t new file mode 100644 index 0000000000..0c84074988 --- /dev/null +++ b/ext/List-Util/t/openhan.t @@ -0,0 +1,29 @@ +#!./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 vars qw(*CLOSED); +use Test::More tests => 4; +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)'); + +is(openhandle(*CLOSED), undef, 'closed'); + diff --git a/ext/List-Util/t/p_blessed.t b/ext/List-Util/t/p_blessed.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_blessed.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_first.t b/ext/List-Util/t/p_first.t new file mode 100644 index 0000000000..cd39ec44be --- /dev/null +++ b/ext/List-Util/t/p_first.t @@ -0,0 +1,8 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once! +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_lln.t b/ext/List-Util/t/p_lln.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_lln.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_max.t b/ext/List-Util/t/p_max.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_max.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_maxstr.t b/ext/List-Util/t/p_maxstr.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_maxstr.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_min.t b/ext/List-Util/t/p_min.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_min.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_minstr.t b/ext/List-Util/t/p_minstr.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_minstr.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_openhan.t b/ext/List-Util/t/p_openhan.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_openhan.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_readonly.t b/ext/List-Util/t/p_readonly.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_readonly.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_reduce.t b/ext/List-Util/t/p_reduce.t new file mode 100644 index 0000000000..cd39ec44be --- /dev/null +++ b/ext/List-Util/t/p_reduce.t @@ -0,0 +1,8 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once! +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_refaddr.t b/ext/List-Util/t/p_refaddr.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_refaddr.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_reftype.t b/ext/List-Util/t/p_reftype.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_reftype.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_shuffle.t b/ext/List-Util/t/p_shuffle.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_shuffle.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_sum.t b/ext/List-Util/t/p_sum.t new file mode 100644 index 0000000000..48e7ef7dcd --- /dev/null +++ b/ext/List-Util/t/p_sum.t @@ -0,0 +1,7 @@ +#!./perl + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +do $f; die $@ if $@; diff --git a/ext/List-Util/t/p_tainted.t b/ext/List-Util/t/p_tainted.t new file mode 100644 index 0000000000..5123a9f6c1 --- /dev/null +++ b/ext/List-Util/t/p_tainted.t @@ -0,0 +1,10 @@ +#!./perl -T + +use File::Spec; + +# force perl-only version to be tested +$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1; + +(my $f = __FILE__) =~ s/p_//; +my $filename = File::Spec->catfile(".", $f); +do $filename; die $@ if $@; diff --git a/ext/List-Util/t/proto.t b/ext/List-Util/t/proto.t new file mode 100644 index 0000000000..50e401b59e --- /dev/null +++ b/ext/List-Util/t/proto.t @@ -0,0 +1,59 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Scalar::Util (); +use Test::More (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL) + ? (skip_all => 'set_prototype requires XS version') + : (tests => 13); + +Scalar::Util->import('set_prototype'); + +sub f { } +is( prototype('f'), undef, 'no prototype'); + +$r = set_prototype(\&f,'$'); +is( prototype('f'), '$', 'set prototype'); +is( $r, \&f, 'return value'); + +set_prototype(\&f,undef); +is( prototype('f'), undef, 'remove prototype'); + +set_prototype(\&f,''); +is( prototype('f'), '', 'empty prototype'); + +sub g (@) { } +is( prototype('g'), '@', '@ prototype'); + +set_prototype(\&g,undef); +is( prototype('g'), undef, 'remove prototype'); + +sub stub; +is( prototype('stub'), undef, 'non existing sub'); + +set_prototype(\&stub,'$$$'); +is( prototype('stub'), '$$$', 'change non existing sub'); + +sub f_decl ($$$$); +is( prototype('f_decl'), '$$$$', 'forward declaration'); + +set_prototype(\&f_decl,'\%'); +is( prototype('f_decl'), '\%', 'change forward declaration'); + +eval { &set_prototype( 'f', '' ); }; +print "not " unless +ok($@ =~ /^set_prototype: not a reference/, 'not a reference'); + +eval { &set_prototype( \'f', '' ); }; +ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference'); diff --git a/ext/List-Util/t/readonly.t b/ext/List-Util/t/readonly.t new file mode 100644 index 0000000000..42ed3d811c --- /dev/null +++ b/ext/List-Util/t/readonly.t @@ -0,0 +1,51 @@ +#!./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; +{ + local $TODO = $Config::Config{useithreads} ? "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/ext/List-Util/t/reduce.t b/ext/List-Util/t/reduce.t new file mode 100755 index 0000000000..d82580de6e --- /dev/null +++ b/ext/List-Util/t/reduce.t @@ -0,0 +1,142 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + + +use List::Util qw(reduce min); +use Test::More; +plan tests => ($::PERL_ONLY ? 21 : 23); + +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"); +} + +# 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"); + +} } diff --git a/ext/List-Util/t/refaddr.t b/ext/List-Util/t/refaddr.t new file mode 100755 index 0000000000..61a33d32ea --- /dev/null +++ b/ext/List-Util/t/refaddr.t @@ -0,0 +1,100 @@ +#!./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 => 29; + +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})); +} + +package FooBar; + +use overload '0+' => sub { 10 }, + '+' => sub { 10 + $_[1] }; + +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/ext/List-Util/t/reftype.t b/ext/List-Util/t/reftype.t new file mode 100755 index 0000000000..6cbc6d0feb --- /dev/null +++ b/ext/List-Util/t/reftype.t @@ -0,0 +1,59 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Test::More tests => 23; + +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'; + +@test = ( + [ undef, 1, 'number' ], + [ undef, 'A', 'string' ], + [ HASH => {}, 'HASH ref' ], + [ ARRAY => [], 'ARRAY ref' ], + [ SCALAR => \$t, 'SCALAR ref' ], + [ REF => \(\$t), 'REF ref' ], + [ GLOB => \*F, 'tied GLOB ref' ], + [ GLOB => gensym, 'GLOB ref' ], + [ CODE => sub {}, 'CODE ref' ], +# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN +); + +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/ext/List-Util/t/shuffle.t b/ext/List-Util/t/shuffle.t new file mode 100755 index 0000000000..d3fbd6cd1f --- /dev/null +++ b/ext/List-Util/t/shuffle.t @@ -0,0 +1,36 @@ +#!./perl + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + keys %Config; # Silence warning + if ($Config{extensions} !~ /\bList\/Util\b/) { + print "1..0 # Skip: List::Util was not built\n"; + exit 0; + } + } +} + +use Test::More tests => 6; + +use List::Util qw(shuffle); + +my @r; + +@r = shuffle(); +ok( !@r, 'no args'); + +@r = shuffle(9); +is( 0+@r, 1, '1 in 1 out'); +is( $r[0], 9, 'one arg'); + +my @in = 1..100; +@r = shuffle(@in); +is( 0+@r, 0+@in, 'arg count'); + +isnt( "@r", "@in", 'result different to args'); + +my @s = sort { $a <=> $b } @r; +is( "@in", "@s", 'values'); diff --git a/ext/List-Util/t/sum.t b/ext/List-Util/t/sum.t new file mode 100755 index 0000000000..4860eeba9e --- /dev/null +++ b/ext/List-Util/t/sum.t @@ -0,0 +1,39 @@ +#!./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(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'); + diff --git a/ext/List-Util/t/tainted.t b/ext/List-Util/t/tainted.t new file mode 100644 index 0000000000..09ad330684 --- /dev/null +++ b/ext/List-Util/t/tainted.t @@ -0,0 +1,34 @@ +#!./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 => 4; + +use Scalar::Util qw(tainted); + +ok( !tainted(1), 'constant number'); + +my $var = 2; + +ok( !tainted($var), 'known variable'); + +my $key = (keys %ENV)[0]; + +ok( tainted($ENV{$key}), 'environment variable'); + +$var = $ENV{$key}; +ok( tainted($var), 'copy of environment variable'); diff --git a/ext/List-Util/t/weak.t b/ext/List-Util/t/weak.t new file mode 100755 index 0000000000..d0c3dff187 --- /dev/null +++ b/ext/List-Util/t/weak.t @@ -0,0 +1,206 @@ +#!./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 { /weaken/ } @Scalar::Util::EXPORT_FAIL) + ? (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 +# + +$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 $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)); + +$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}} ++; +} |