Change 26794 by [EMAIL PROTECTED] on 2006/01/11 21:07:15
Integrate the ext/List/Utils/... parts of:
[ 25953]
Subject: [PATCH] sort/multicall patch
From: Robin Houston <[EMAIL PROTECTED]>
Date: Sat, 29 Oct 2005 21:33:07 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 25955]
Add missing file from change 25953
[ 26054]
Subject: [PATCH] Re: [perl #32383] DProf breaks List::Util::shuffle
From: Robin Houston <[EMAIL PROTECTED]>
Date: Tue, 8 Nov 2005 19:02:34 +0000
Message-ID: <[EMAIL PROTECTED]>
[ 26062]
Subject: Re: [PATCH] Re: [perl #32383] DProf breaks List::Util::shuffle
From: Graham Barr <[EMAIL PROTECTED]>
Date: Wed, 9 Nov 2005 06:09:48 -0600
Message-Id: <[EMAIL PROTECTED]>
[ 26212]
Upgrade to Scalar-List-Utils-1.18
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#269 integrate
... //depot/maint-5.8/perl/ext/List/Util/Changes#3 integrate
... //depot/maint-5.8/perl/ext/List/Util/Util.xs#16 integrate
... //depot/maint-5.8/perl/ext/List/Util/lib/List/Util.pm#11 integrate
... //depot/maint-5.8/perl/ext/List/Util/lib/Scalar/Util.pm#9 integrate
... //depot/maint-5.8/perl/ext/List/Util/multicall.h#1 branch
... //depot/maint-5.8/perl/ext/List/Util/t/00version.t#1 branch
... //depot/maint-5.8/perl/ext/List/Util/t/first.t#4 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/lln.t#5 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_blessed.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_first.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_lln.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_max.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_maxstr.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_min.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_minstr.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_openhan.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_readonly.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_reduce.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_refaddr.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_reftype.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_shuffle.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_sum.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/p_tainted.t#2 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/reduce.t#5 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/refaddr.t#4 integrate
... //depot/maint-5.8/perl/ext/List/Util/t/tainted.t#4 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#269 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#268~26730~ 2006-01-08 10:40:54.000000000 -0800
+++ perl/MANIFEST 2006-01-11 13:07:15.000000000 -0800
@@ -638,7 +638,9 @@
ext/List/Util/lib/List/Util.pm List::Util
ext/List/Util/lib/Scalar/Util.pm Scalar::Util
ext/List/Util/Makefile.PL Util extension
+ext/List/Util/multicall.h Util extension
ext/List/Util/README Util extension
+ext/List/Util/t/00version.t Scalar::Util
ext/List/Util/t/blessed.t Scalar::Util
ext/List/Util/t/dualvar.t Scalar::Util
ext/List/Util/t/first.t List::Util
==== //depot/maint-5.8/perl/ext/List/Util/Changes#3 (text) ====
Index: perl/ext/List/Util/Changes
--- perl/ext/List/Util/Changes#2~25485~ 2005-09-19 05:01:22.000000000 -0700
+++ perl/ext/List/Util/Changes 2006-01-11 13:07:15.000000000 -0800
@@ -1,3 +1,15 @@
+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
==== //depot/maint-5.8/perl/ext/List/Util/Util.xs#16 (text) ====
Index: perl/ext/List/Util/Util.xs
--- perl/ext/List/Util/Util.xs#15~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/Util.xs 2006-01-11 13:07:15.000000000 -0800
@@ -17,11 +17,14 @@
# 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
@@ -127,6 +130,10 @@
#define dVAR dNOOP
#endif
+#ifndef GvSVn
+# define GvSVn GvSV
+#endif
+
MODULE=List::Util PACKAGE=List::Util
void
@@ -224,58 +231,41 @@
+#ifdef dMULTICALL
+
void
reduce(block,...)
SV * block
PROTOTYPE: &@
CODE:
{
- dVAR;
+ dVAR; dMULTICALL;
SV *ret = sv_newmortal();
int index;
GV *agv,*bgv,*gv;
HV *stash;
- CV *cv;
- OP *reducecop;
- PERL_CONTEXT *cx;
- SV** newsp;
I32 gimme = G_SCALAR;
- U8 hasargs = 0;
- bool oldcatch = CATCH_GET;
+ 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;
- cv = sv_2cv(block, &stash, &gv, 0);
- reducecop = CvSTART(cv);
- SAVESPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
- PAD_SET_CUR(CvPADLIST(cv),1);
-#else
- SAVESPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
- SAVETMPS;
- SAVESPTR(PL_op);
- SvSetSV(ret, ST(1));
- CATCH_SET(TRUE);
- PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
+ SvSetSV(ret, args[1]);
for(index = 2 ; index < items ; index++) {
- GvSV(bgv) = ST(index);
- PL_op = reducecop;
- CALLRUNOPS(aTHX);
+ GvSV(bgv) = args[index];
+ MULTICALL;
SvSetSV(ret, *PL_stack_sp);
}
+ POP_MULTICALL;
ST(0) = ret;
- POPBLOCK(cx,PL_curpm);
- CATCH_SET(oldcatch);
XSRETURN(1);
}
@@ -285,54 +275,36 @@
PROTOTYPE: &@
CODE:
{
- dVAR;
+ dVAR; dMULTICALL;
int index;
GV *gv;
HV *stash;
- CV *cv;
- OP *reducecop;
- PERL_CONTEXT *cx;
- SV** newsp;
I32 gimme = G_SCALAR;
- U8 hasargs = 0;
- bool oldcatch = CATCH_GET;
+ SV **args = &PL_stack_base[ax];
+ CV *cv;
if(items <= 1) {
XSRETURN_UNDEF;
}
- SAVESPTR(GvSV(PL_defgv));
cv = sv_2cv(block, &stash, &gv, 0);
- reducecop = CvSTART(cv);
- SAVESPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
- PAD_SET_CUR(CvPADLIST(cv),1);
-#else
- SAVESPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
- SAVETMPS;
- SAVESPTR(PL_op);
- CATCH_SET(TRUE);
- PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
+ PUSH_MULTICALL(cv);
+ SAVESPTR(GvSV(PL_defgv));
for(index = 1 ; index < items ; index++) {
- GvSV(PL_defgv) = ST(index);
- PL_op = reducecop;
- CALLRUNOPS(aTHX);
+ GvSV(PL_defgv) = args[index];
+ MULTICALL;
if (SvTRUE(*PL_stack_sp)) {
+ POP_MULTICALL;
ST(0) = ST(index);
- POPBLOCK(cx,PL_curpm);
- CATCH_SET(oldcatch);
XSRETURN(1);
}
}
- POPBLOCK(cx,PL_curpm);
- CATCH_SET(oldcatch);
+ POP_MULTICALL;
XSRETURN_UNDEF;
}
+#endif
+
void
shuffle(...)
PROTOTYPE: @
@@ -340,6 +312,7 @@
{
dVAR;
int index;
+#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <1)
struct op dmy_op;
struct op *old_op = PL_op;
@@ -352,6 +325,16 @@
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);
@@ -502,7 +485,16 @@
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
@@ -538,14 +530,20 @@
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 *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
- GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
+ 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, stash, "Scalar::Util", 12, TRUE);
+ 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));
@@ -553,4 +551,9 @@
#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
}
==== //depot/maint-5.8/perl/ext/List/Util/lib/List/Util.pm#11 (text) ====
Index: perl/ext/List/Util/lib/List/Util.pm
--- perl/ext/List/Util/lib/List/Util.pm#10~25485~ 2005-09-19
05:01:22.000000000 -0700
+++ perl/ext/List/Util/lib/List/Util.pm 2006-01-11 13:07:15.000000000 -0800
@@ -6,11 +6,13 @@
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.17";
+$VERSION = "1.18";
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -18,23 +20,32 @@
# 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};
- require DynaLoader;
- local @ISA = qw(DynaLoader);
- bootstrap List::Util $XS_VERSION;
- 1
-};
+ 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;
-eval <<'ESQ' unless defined &reduce;
# This code is only compiled if the XS did not load
+# of for perl < 5.6.0
-use vars qw($a $b);
+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;
@@ -48,16 +59,6 @@
$a;
}
-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 first (&@) {
my $code = shift;
@@ -68,6 +69,24 @@
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;
@@ -201,7 +220,8 @@
=item sum LIST
-Returns the sum of all the elements in 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
==== //depot/maint-5.8/perl/ext/List/Util/lib/Scalar/Util.pm#9 (text) ====
Index: perl/ext/List/Util/lib/Scalar/Util.pm
--- perl/ext/List/Util/lib/Scalar/Util.pm#8~25485~ 2005-09-19
05:01:22.000000000 -0700
+++ perl/ext/List/Util/lib/Scalar/Util.pm 2006-01-11 13:07:15.000000000
-0800
@@ -6,12 +6,14 @@
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.17";
+$VERSION = "1.18";
$VERSION = eval $VERSION;
sub export_fail {
@@ -51,6 +53,7 @@
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
@@ -67,10 +70,15 @@
sub refaddr($) {
my $pkg = ref($_[0]) or return undef;
- bless $_[0], 'Scalar::Util::Fake';
+ if (blessed($_[0])) {
+ bless $_[0], 'Scalar::Util::Fake';
+ }
+ else {
+ $pkg = undef;
+ }
"$_[0]" =~ /0x(\w+)/;
my $i = do { local $^W; hex $1 };
- bless $_[0], $pkg;
+ bless $_[0], $pkg if defined $pkg;
$i;
}
@@ -123,7 +131,7 @@
local $_ = shift;
# checks from perlfaq4
- return $] < 5.008005 unless defined;
+ 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);
@@ -143,7 +151,8 @@
=head1 SYNOPSIS
- use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype
tainted weaken isvstring looks_like_number set_prototype);
+ use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
+ weaken isvstring looks_like_number set_prototype);
=head1 DESCRIPTION
@@ -197,6 +206,11 @@
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
==== //depot/maint-5.8/perl/ext/List/Util/multicall.h#1 (text) ====
Index: perl/ext/List/Util/multicall.h
--- /dev/null 2005-11-29 02:13:17.616583056 -0800
+++ perl/ext/List/Util/multicall.h 2006-01-11 13:07:15.000000000 -0800
@@ -0,0 +1,165 @@
+/* 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; \
+ } STMT_END
+
+#endif
==== //depot/maint-5.8/perl/ext/List/Util/t/00version.t#1 (text) ====
Index: perl/ext/List/Util/t/00version.t
--- /dev/null 2005-11-29 02:13:17.616583056 -0800
+++ perl/ext/List/Util/t/00version.t 2006-01-11 13:07:15.000000000 -0800
@@ -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");
+
+
==== //depot/maint-5.8/perl/ext/List/Util/t/first.t#4 (xtext) ====
Index: perl/ext/List/Util/t/first.t
--- perl/ext/List/Util/t/first.t#3~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/first.t 2006-01-11 13:07:15.000000000 -0800
@@ -13,8 +13,9 @@
}
}
-use Test::More tests => 8;
use List::Util qw(first);
+use Test::More;
+plan tests => ($::PERL_ONLY ? 15 : 17);
my $v;
ok(defined &first, 'defined');
@@ -45,4 +46,70 @@
($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");
+} }
==== //depot/maint-5.8/perl/ext/List/Util/t/lln.t#5 (text) ====
Index: perl/ext/List/Util/t/lln.t
--- perl/ext/List/Util/t/lln.t#4~25485~ 2005-09-19 05:01:22.000000000 -0700
+++ perl/ext/List/Util/t/lln.t 2006-01-11 13:07:15.000000000 -0800
@@ -14,7 +14,7 @@
}
use strict;
-use Test::More tests => 12;
+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)) {
@@ -25,6 +25,13 @@
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), $] < 5.008005, 'undef');
+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
==== //depot/maint-5.8/perl/ext/List/Util/t/p_blessed.t#2 (text) ====
Index: perl/ext/List/Util/t/p_blessed.t
--- perl/ext/List/Util/t/p_blessed.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_blessed.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_first.t#2 (text) ====
Index: perl/ext/List/Util/t/p_first.t
--- perl/ext/List/Util/t/p_first.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_first.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,8 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$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;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_lln.t#2 (text) ====
Index: perl/ext/List/Util/t/p_lln.t
--- perl/ext/List/Util/t/p_lln.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_lln.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_max.t#2 (text) ====
Index: perl/ext/List/Util/t/p_max.t
--- perl/ext/List/Util/t/p_max.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_max.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_maxstr.t#2 (text) ====
Index: perl/ext/List/Util/t/p_maxstr.t
--- perl/ext/List/Util/t/p_maxstr.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_maxstr.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_min.t#2 (text) ====
Index: perl/ext/List/Util/t/p_min.t
--- perl/ext/List/Util/t/p_min.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_min.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_minstr.t#2 (text) ====
Index: perl/ext/List/Util/t/p_minstr.t
--- perl/ext/List/Util/t/p_minstr.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_minstr.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_openhan.t#2 (text) ====
Index: perl/ext/List/Util/t/p_openhan.t
--- perl/ext/List/Util/t/p_openhan.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_openhan.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_readonly.t#2 (text) ====
Index: perl/ext/List/Util/t/p_readonly.t
--- perl/ext/List/Util/t/p_readonly.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_readonly.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_reduce.t#2 (text) ====
Index: perl/ext/List/Util/t/p_reduce.t
--- perl/ext/List/Util/t/p_reduce.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_reduce.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,8 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$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;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_refaddr.t#2 (text) ====
Index: perl/ext/List/Util/t/p_refaddr.t
--- perl/ext/List/Util/t/p_refaddr.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_refaddr.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_reftype.t#2 (text) ====
Index: perl/ext/List/Util/t/p_reftype.t
--- perl/ext/List/Util/t/p_reftype.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_reftype.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_shuffle.t#2 (text) ====
Index: perl/ext/List/Util/t/p_shuffle.t
--- perl/ext/List/Util/t/p_shuffle.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_shuffle.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_sum.t#2 (text) ====
Index: perl/ext/List/Util/t/p_sum.t
--- perl/ext/List/Util/t/p_sum.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_sum.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,7 +1,7 @@
#!./perl
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
(my $f = __FILE__) =~ s/p_//;
do $f;
==== //depot/maint-5.8/perl/ext/List/Util/t/p_tainted.t#2 (text) ====
Index: perl/ext/List/Util/t/p_tainted.t
--- perl/ext/List/Util/t/p_tainted.t#1~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/p_tainted.t 2006-01-11 13:07:15.000000000 -0800
@@ -1,34 +1,7 @@
#!./perl -T
# force perl-only version to be tested
-sub List::Util::bootstrap {}
+$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
-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 => 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');
+(my $f = __FILE__) =~ s/p_//;
+do "./$f";
==== //depot/maint-5.8/perl/ext/List/Util/t/reduce.t#5 (xtext) ====
Index: perl/ext/List/Util/t/reduce.t
--- perl/ext/List/Util/t/reduce.t#4~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/reduce.t 2006-01-11 13:07:15.000000000 -0800
@@ -15,7 +15,8 @@
use List::Util qw(reduce min);
-use Test::More tests => 14;
+use Test::More;
+plan tests => ($::PERL_ONLY ? 21 : 23);
my $v = reduce {};
@@ -70,3 +71,72 @@
$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");
+
+} }
==== //depot/maint-5.8/perl/ext/List/Util/t/refaddr.t#4 (xtext) ====
Index: perl/ext/List/Util/t/refaddr.t
--- perl/ext/List/Util/t/refaddr.t#3~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/refaddr.t 2006-01-11 13:07:15.000000000 -0800
@@ -14,7 +14,7 @@
}
-use Test::More tests => 19;
+use Test::More tests => 29;
use Scalar::Util qw(refaddr);
use vars qw($t $y $x *F $v $r);
@@ -32,10 +32,13 @@
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);
}
{
==== //depot/maint-5.8/perl/ext/List/Util/t/tainted.t#4 (text) ====
Index: perl/ext/List/Util/t/tainted.t
--- perl/ext/List/Util/t/tainted.t#3~25485~ 2005-09-19 05:01:22.000000000
-0700
+++ perl/ext/List/Util/t/tainted.t 2006-01-11 13:07:15.000000000 -0800
@@ -11,6 +11,9 @@
exit 0;
}
}
+ elsif(!grep {/blib/} @INC) {
+ unshift(@INC, qw(./inc ./blib/arch ./blib/lib));
+ }
}
use Test::More tests => 4;
End of Patch.
