develooper Front page | perl.perl5.porters | Postings from October 2005

sort/multicall patch: getting there

Thread Next
From:
Robin Houston
Date:
October 28, 2005 03:31
Subject:
sort/multicall patch: getting there
Message ID:
20051028102755.GA2076@rpc142.cs.man.ac.uk
I think this patch has all the essentials. Do you think there's
something essential missing?

More importantly, does it work on your system? (Especially if
your system is Win32 with it's bondage-and-discipline treatment
of exports.)

I've hacked together a header file "multicall.h", which does its
best to emulate the multicall API on older versions of perl. I
think it does a reasonable job of it. It's intended for modules
that want to use the API but don't want to 'require 5.009_004'
just yet. It makes it possible to keep the core version of
List::Util in sync with the CPAN version (assuming Graham is
willing to apply this to the CPAN version, of course).

Robin

diff -ru perl-current/AUTHORS perl-hackery/AUTHORS
--- perl-current/AUTHORS	2005-09-13 19:43:54.000000000 +0100
+++ perl-hackery/AUTHORS	2005-10-27 07:33:44.000000000 +0100
@@ -692,7 +692,7 @@
 Robert Sanders			<Robert.Sanders@linux.org>
 Robert Spier			<rspier@pobox.com>
 Robin Barker			<RMBarker@cpan.org>
-Robin Houston			<robin@kitsite.com>
+Robin Houston			<robin@cpan.org>
 Rocco Caputo			<troc@netrus.net>
 Roderick Schertler		<roderick@argon.org>
 Rodger Anderson			<rodger@boi.hp.com>
diff -ru perl-current/MANIFEST perl-hackery/MANIFEST
--- perl-current/MANIFEST	2005-10-26 14:08:44.000000000 +0100
+++ perl-hackery/MANIFEST	2005-10-27 07:33:44.000000000 +0100
@@ -706,6 +706,7 @@
 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/blessed.t	Scalar::Util
 ext/List/Util/t/dualvar.t	Scalar::Util
diff -ru perl-current/cop.h perl-hackery/cop.h
--- perl-current/cop.h	2005-10-04 11:37:01.000000000 +0100
+++ perl-hackery/cop.h	2005-10-27 07:33:44.000000000 +0100
@@ -541,6 +541,10 @@
 #define CXt_BLOCK	5
 #define CXt_FORMAT	6
 
+/* private flags for CXt_SUB and CXt_NULL */
+#define CXp_MULTICALL	0x00000400	/* part of a multicall (so don't
+					   tear down context on exit). */ 
+
 /* private flags for CXt_EVAL */
 #define CXp_REAL	0x00000100	/* truly eval'', not a lookalike */
 #define CXp_TRYBLOCK	0x00000200	/* eval{}, not eval'' or similar */
@@ -555,6 +559,8 @@
 #endif
 
 #define CxTYPE(c)	((c)->cx_type & CXTYPEMASK)
+#define CxMULTICALL(c)	(((c)->cx_type & CXp_MULTICALL)			\
+			 == CXp_MULTICALL)
 #define CxREALEVAL(c)	(((c)->cx_type & (CXt_EVAL|CXp_REAL))		\
 			 == (CXt_EVAL|CXp_REAL))
 #define CxTRYBLOCK(c)	(((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK))	\
@@ -700,3 +706,63 @@
 #define IN_PERL_COMPILETIME	(PL_curcop == &PL_compiling)
 #define IN_PERL_RUNTIME		(PL_curcop != &PL_compiling)
 
+/*
+=head1 Multicall Functions
+
+=for apidoc Ams||dMULTICALL
+Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||PUSH_MULTICALL
+Opening bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||MULTICALL
+Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||POP_MULTICALL
+Closing bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=cut
+*/
+
+#define dMULTICALL \
+    SV **newsp;			/* set by POPBLOCK */			\
+    PERL_CONTEXT *cx;							\
+    CV *cv;								\
+    OP *multicall_cop;							\
+    bool multicall_oldcatch; 						\
+    U8 hasargs = 0;		/* used by PUSHSUB */
+
+#define PUSH_MULTICALL \
+    STMT_START {							\
+	AV* padlist = CvPADLIST(cv);					\
+	ENTER;								\
+ 	multicall_oldcatch = CATCH_GET;					\
+	SAVETMPS; SAVEVPTR(PL_op);					\
+	CATCH_SET(TRUE);						\
+	PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);		\
+	PUSHSUB(cx);							\
+	if (++CvDEPTH(cv) >= 2) {					\
+	    PERL_STACK_OVERFLOW_CHECK();				\
+	    Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));			\
+	}								\
+	SAVECOMPPAD();							\
+	PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));			\
+	multicall_cop = CvSTART(cv);					\
+    } STMT_END
+
+#define MULTICALL \
+    STMT_START {							\
+	PL_op = multicall_cop;						\
+	CALLRUNOPS(aTHX);						\
+    } STMT_END
+
+#define POP_MULTICALL \
+    STMT_START {							\
+	LEAVESUB(cv);							\
+	CvDEPTH(cv)--;							\
+	POPBLOCK(cx,PL_curpm);						\
+	CATCH_SET(multicall_oldcatch);					\
+	LEAVE;								\
+    } STMT_END
diff -ru perl-current/embed.fnc perl-hackery/embed.fnc
--- perl-current/embed.fnc	2005-10-26 10:02:35.000000000 +0100
+++ perl-hackery/embed.fnc	2005-10-27 07:33:44.000000000 +0100
@@ -1418,7 +1418,7 @@
 pd 	|void	|do_dump_pad	|I32 level|NN PerlIO *file|NULLOK PADLIST *padlist|int full
 pd	|void	|pad_fixup_inner_anons|NN PADLIST *padlist|NN CV *old_cv|NN CV *new_cv
 
-pd	|void	|pad_push	|NN PADLIST *padlist|int depth
+pdX	|void	|pad_push	|NN PADLIST *padlist|int depth
 pR	|HV*	|pad_compname_type|const PADOFFSET po
 
 #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
diff -ru perl-current/embedvar.h perl-hackery/embedvar.h
--- perl-current/embedvar.h	2005-06-29 09:41:56.000000000 +0100
+++ perl-hackery/embedvar.h	2005-10-27 07:33:44.000000000 +0100
@@ -138,7 +138,6 @@
 #define PL_screamnext		(vTHX->Tscreamnext)
 #define PL_secondgv		(vTHX->Tsecondgv)
 #define PL_sortcop		(vTHX->Tsortcop)
-#define PL_sortcxix		(vTHX->Tsortcxix)
 #define PL_sortstash		(vTHX->Tsortstash)
 #define PL_stack_base		(vTHX->Tstack_base)
 #define PL_stack_max		(vTHX->Tstack_max)
@@ -861,7 +860,6 @@
 #define PL_Tscreamnext		PL_screamnext
 #define PL_Tsecondgv		PL_secondgv
 #define PL_Tsortcop		PL_sortcop
-#define PL_Tsortcxix		PL_sortcxix
 #define PL_Tsortstash		PL_sortstash
 #define PL_Tstack_base		PL_stack_base
 #define PL_Tstack_max		PL_stack_max
diff -ru perl-current/ext/List/Util/Util.xs perl-hackery/ext/List/Util/Util.xs
--- perl-current/ext/List/Util/Util.xs	2005-05-21 00:00:19.000000000 +0100
+++ perl-hackery/ext/List/Util/Util.xs	2005-10-27 07:33:44.000000000 +0100
@@ -7,6 +7,8 @@
 #include <perl.h>
 #include <XSUB.h>
 
+#include "multicall.h"
+
 #ifndef PERL_VERSION
 #    include <patchlevel.h>
 #    if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
@@ -230,52 +232,32 @@
 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];
 
     if(items <= 1) {
 	XSRETURN_UNDEF;
     }
+    cv = sv_2cv(block, &stash, &gv, 0);
+    PUSH_MULTICALL;
     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,51 +267,30 @@
 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];
 
     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;
+    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;
 }
 
diff -ru perl-current/ext/List/Util/lib/List/Util.pm perl-hackery/ext/List/Util/lib/List/Util.pm
--- perl-current/ext/List/Util/lib/List/Util.pm	2005-05-23 15:20:38.000000000 +0100
+++ perl-hackery/ext/List/Util/lib/List/Util.pm	2005-10-27 07:33:44.000000000 +0100
@@ -10,7 +10,7 @@
 
 @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;
 
diff -ru perl-current/ext/List/Util/lib/Scalar/Util.pm perl-hackery/ext/List/Util/lib/Scalar/Util.pm
--- perl-current/ext/List/Util/lib/Scalar/Util.pm	2005-05-23 15:20:38.000000000 +0100
+++ perl-hackery/ext/List/Util/lib/Scalar/Util.pm	2005-10-28 11:01:29.000000000 +0100
@@ -11,7 +11,7 @@
 
 @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 {
diff -ru perl-current/ext/List/Util/multicall.h perl-hackery/ext/List/Util/multicall.h
--- perl-current/ext/List/Util/multicall.h	2005-10-28 11:02:58.000000000 +0100
+++ perl-hackery/ext/List/Util/multicall.h	2005-10-27 07:33:44.000000000 +0100
@@ -0,0 +1,126 @@
+/*    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.
+ *
+ */
+
+#ifndef dMULTICALL
+
+/* 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.
+ */
+
+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 *cv;								\
+    OP *multicall_cop;							\
+    bool multicall_oldcatch;						\
+    U8 hasargs = 0;
+
+#ifndef PUSHSUB_BASE
+#  define PUSHSUB_BASE PUSHSUB
+#endif
+
+#define PUSH_MULTICALL \
+    STMT_START {							\
+	AV* padlist = CvPADLIST(cv);					\
+	ENTER;								\
+ 	multicall_oldcatch = CATCH_GET;					\
+	SAVESPTR(CvROOT(cv)->op_ppaddr);				\
+	CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];			\
+	SAVETMPS; SAVEVPTR(PL_op);					\
+	CATCH_SET(TRUE);						\
+	PUSHSTACKi(PERLSI_SORT);					\
+	PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);				\
+	PUSHSUB_BASE(cx);						\
+	if (!CvDEPTH(cv)) {                                             \
+	    (void)SvREFCNT_inc(cv);                                     \
+	    (void)SvREFCNT_inc(cv);                                     \
+	    SAVEFREESV(cv);                                             \
+	}								\
+	 if (++CvDEPTH(cv) >= 2) {					\
+	    PERL_STACK_OVERFLOW_CHECK();				\
+	    multicall_pad_push(aTHX_ padlist, CvDEPTH(cv));		\
+	}								\
+	SAVECOMPPAD();							\
+	PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(cv)]);		\
+	PL_curpad = AvARRAY(PL_comppad);				\
+	multicall_cop = CvSTART(cv);					\
+    } STMT_END
+
+#define MULTICALL \
+    STMT_START {							\
+	PL_op = multicall_cop;						\
+	CALLRUNOPS(aTHX);						\
+    } STMT_END
+
+#define POP_MULTICALL \
+    STMT_START {							\
+	CvDEPTH(cv)--;							\
+	LEAVESUB(cv);							\
+	POPBLOCK(cx,PL_curpm);						\
+	POPSTACK;							\
+	CATCH_SET(multicall_oldcatch);					\
+	LEAVE;								\
+    } STMT_END
+
+#endif
diff -ru perl-current/ext/List/Util/t/first.t perl-hackery/ext/List/Util/t/first.t
--- perl-current/ext/List/Util/t/first.t	2005-05-13 22:09:18.000000000 +0100
+++ perl-hackery/ext/List/Util/t/first.t	2005-10-28 11:16:58.000000000 +0100
@@ -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.
+no warnings 'redefine';
+
+sub self_updating { *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: {
+
+    skip("Poor man's MULTICALL can't cope", 2)
+      if $] < 5.009003;
+
+    # 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 -ru perl-current/ext/List/Util/t/p_first.t perl-hackery/ext/List/Util/t/p_first.t
--- perl-current/ext/List/Util/t/p_first.t	2005-05-13 22:09:18.000000000 +0100
+++ perl-hackery/ext/List/Util/t/p_first.t	2005-10-27 07:33:44.000000000 +0100
@@ -4,4 +4,5 @@
 sub List::Util::bootstrap {}
 
 (my $f = __FILE__) =~ s/p_//;
+$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
 do $f;
diff -ru perl-current/ext/List/Util/t/p_reduce.t perl-hackery/ext/List/Util/t/p_reduce.t
--- perl-current/ext/List/Util/t/p_reduce.t	2005-05-13 22:09:18.000000000 +0100
+++ perl-hackery/ext/List/Util/t/p_reduce.t	2005-10-27 07:33:44.000000000 +0100
@@ -4,4 +4,5 @@
 sub List::Util::bootstrap {}
 
 (my $f = __FILE__) =~ s/p_//;
+$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
 do $f;
diff -ru perl-current/ext/List/Util/t/reduce.t perl-hackery/ext/List/Util/t/reduce.t
--- perl-current/ext/List/Util/t/reduce.t	2005-05-13 22:09:18.000000000 +0100
+++ perl-hackery/ext/List/Util/t/reduce.t	2005-10-28 11:16:31.000000000 +0100
@@ -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,71 @@
 $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; no warnings 'once';
+  ::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.
+no warnings 'redefine';
+
+sub self_updating { *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: {
+
+    skip("Poor man's MULTICALL can't cope", 2)
+      if $] < 5.009003;
+
+    # 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 -ru perl-current/global.sym perl-hackery/global.sym
--- perl-current/global.sym	2005-10-24 22:48:54.000000000 +0100
+++ perl-hackery/global.sym	2005-10-27 07:33:44.000000000 +0100
@@ -681,6 +681,7 @@
 Perl_PerlIO_stdin
 Perl_PerlIO_stdout
 Perl_PerlIO_stderr
+Perl_pad_push
 Perl_save_set_svflags
 Perl_hv_assert
 Perl_hv_scalar
diff -ru perl-current/makedef.pl perl-hackery/makedef.pl
--- perl-current/makedef.pl	2005-10-26 10:02:35.000000000 +0100
+++ perl-hackery/makedef.pl	2005-10-27 07:33:44.000000000 +0100
@@ -250,7 +250,6 @@
 		     PL_linestart
 		     PL_modcount
 		     PL_pending_ident
-		     PL_sortcxix
 		     PL_sublex_info
 		     PL_timesbuf
 		     main
@@ -308,7 +307,6 @@
 		     PL_linestart
 		     PL_modcount
 		     PL_pending_ident
-		     PL_sortcxix
 		     PL_sublex_info
 		     PL_timesbuf
 		     PL_collation_ix
@@ -509,7 +507,6 @@
 			PL_linestart
 			PL_modcount
 			PL_pending_ident
-			PL_sortcxix
 			PL_sublex_info
 			PL_timesbuf
 			main
diff -ru perl-current/op.c perl-hackery/op.c
--- perl-current/op.c	2005-10-24 16:48:18.000000000 +0100
+++ perl-hackery/op.c	2005-10-27 07:33:44.000000000 +0100
@@ -4361,9 +4361,6 @@
 		SAVEFREESV(PL_compcv);
 		goto done;
 	    }
-	    /* ahem, death to those who redefine active sort subs */
-	    if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
-		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
 	    if (block) {
 		if (ckWARN(WARN_REDEFINE)
 		    || (CvCONST(cv)
diff -ru perl-current/perlapi.h perl-hackery/perlapi.h
--- perl-current/perlapi.h	2005-10-26 10:02:35.000000000 +0100
+++ perl-hackery/perlapi.h	2005-10-27 07:33:44.000000000 +0100
@@ -910,8 +910,6 @@
 #define PL_secondgv		(*Perl_Tsecondgv_ptr(aTHX))
 #undef  PL_sortcop
 #define PL_sortcop		(*Perl_Tsortcop_ptr(aTHX))
-#undef  PL_sortcxix
-#define PL_sortcxix		(*Perl_Tsortcxix_ptr(aTHX))
 #undef  PL_sortstash
 #define PL_sortstash		(*Perl_Tsortstash_ptr(aTHX))
 #undef  PL_stack_base
diff -ru perl-current/pod/perlcall.pod perl-hackery/pod/perlcall.pod
--- perl-current/pod/perlcall.pod	2004-08-07 16:35:13.000000000 +0100
+++ perl-hackery/pod/perlcall.pod	2005-10-28 10:57:59.000000000 +0100
@@ -1942,6 +1942,51 @@
 L<perlapi/eval_pv>).  Once this code reference is in hand, it
 can be mixed in with all the previous examples we've shown.
 
+=head1 LIGHTWEIGHT CALLBACKS
+
+Sometimes you need to invoke the same subroutine repeatedly.
+This usually happens with a function that acts on a list of
+values, such as Perl's built-in sort(). You can pass a
+comparison function to sort(), which will then be invoked
+for every pair of values that needs to be compared. The first()
+and reduce() functions from L<List::Util> follow a similar
+pattern.
+
+In this case it is possible to speed up the routine (often
+quite substantially) by using the lightweight callback API.
+The idea is that the calling context only needs to be
+created and destroyed once, and the sub can be called
+arbitrarily many times in between.
+
+It is usual to pass parameters using global variables -- typically
+$_ for one parameter, or $a and $b for two parameters -- rather
+than via @_. (It is possible to use the @_ mechanism if you know
+what you're doing, though there is as yet no supported API for
+it. It's also inherently slower.)
+
+The pattern of macro calls is like this:
+
+    dMULTICALL;			/* Declare variables (including 'CV* cv') */
+    I32 gimme = G_SCALAR;	/* context of the call: G_SCALAR,
+				 * G_LIST, or G_VOID */
+
+    /* Here you must arrange for 'cv' to be set to the CV of
+     * the sub you want to call. */
+
+    PUSH_MULTICALL;		/* Set up the calling context */
+
+    /* loop */ {
+        /* set the value(s) af your parameter variables */
+        MULTICALL;		/* Make the actual call */
+    } /* end of loop */
+
+    POP_MULTICALL;		/* Tear down the calling context */
+
+For some concrete examples, see the implementation of the
+first() and reduce() functions of List::Util 1.18. There you
+will also find a header file that emulates the multicall API
+on older versions of perl.
+
 =head1 SEE ALSO
 
 L<perlxs>, L<perlguts>, L<perlembed>
diff -ru perl-current/pod/perldiag.pod perl-hackery/pod/perldiag.pod
--- perl-current/pod/perldiag.pod	2005-10-21 14:54:36.000000000 +0100
+++ perl-hackery/pod/perldiag.pod	2005-10-27 07:33:44.000000000 +0100
@@ -761,6 +761,11 @@
 you tried to jump out of a sort() block or subroutine, which is a no-no.
 See L<perlfunc/goto>.
 
+=item Can't goto subroutine from a sort sub (or similar callback)
+(F) The "goto subroutine" call can't be used to jump out of the
+comparison sub for a sort(), or from a similar callback (such
+as the reduce() function in List::Util).
+
 =item Can't goto subroutine from an eval-%s
 
 (F) The "goto subroutine" call can't be used to jump out of an eval
@@ -954,13 +959,6 @@
 or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not
 searched.
 
-=item Can't redefine active sort subroutine %s
-
-(F) Perl optimizes the internal handling of sort subroutines and keeps
-pointers into them.  You tried to redefine one such sort subroutine when
-it was currently active, which is not allowed.  If you really want to do
-this, you should write C<sort { &func } @x> instead of C<sort func @x>.
-
 =item Can't "redo" outside a loop block
 
 (F) A "redo" statement was executed to restart the current block, but
diff -ru perl-current/pp_ctl.c perl-hackery/pp_ctl.c
--- perl-current/pp_ctl.c	2005-10-19 09:46:58.000000000 +0100
+++ perl-hackery/pp_ctl.c	2005-10-27 07:33:44.000000000 +0100
@@ -1963,24 +1963,23 @@
     SV *sv;
     OP *retop;
 
-    if (PL_curstackinfo->si_type == PERLSI_SORT) {
-	if (cxstack_ix == PL_sortcxix
-	    || dopoptosub(cxstack_ix) <= PL_sortcxix)
-	{
-	    if (cxstack_ix > PL_sortcxix)
-		dounwind(PL_sortcxix);
-	    AvARRAY(PL_curstack)[1] = *SP;
-	    PL_stack_sp = PL_stack_base + 1;
+    cxix = dopoptosub(cxstack_ix);
+    if (cxix < 0) {
+	if (CxMULTICALL(cxstack)) { /* In this case we must be in a
+				     * sort block, which is a CXt_NULL
+				     * not a CXt_SUB */
+	    dounwind(0);
 	    return 0;
 	}
+	else
+	    DIE(aTHX_ "Can't return outside a subroutine");
     }
-
-    cxix = dopoptosub(cxstack_ix);
-    if (cxix < 0)
-	DIE(aTHX_ "Can't return outside a subroutine");
     if (cxix < cxstack_ix)
 	dounwind(cxix);
 
+    if (CxMULTICALL(&cxstack[cxix]))
+	return 0;
+
     POPBLOCK(cx,newpm);
     switch (CxTYPE(cx)) {
     case CXt_SUB:
@@ -2337,6 +2336,8 @@
 		else
 		    DIE(aTHX_ "Can't goto subroutine from an eval-block");
 	    }
+	    else if (CxMULTICALL(cx))
+		DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
 	    if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
 		/* put @_ back onto stack */
 		AV* av = cx->blk_sub.argarray;
@@ -2549,7 +2550,7 @@
 		    gotoprobe = PL_main_root;
 		break;
 	    case CXt_SUB:
-		if (CvDEPTH(cx->blk_sub.cv)) {
+		if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
 		    gotoprobe = CvROOT(cx->blk_sub.cv);
 		    break;
 		}
diff -ru perl-current/pp_hot.c perl-hackery/pp_hot.c
--- perl-current/pp_hot.c	2005-10-19 09:46:58.000000000 +0100
+++ perl-hackery/pp_hot.c	2005-10-27 07:33:44.000000000 +0100
@@ -2331,6 +2331,9 @@
     register PERL_CONTEXT *cx;
     SV *sv;
 
+    if (CxMULTICALL(&cxstack[cxstack_ix]))
+	return 0;
+
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
 
@@ -2391,6 +2394,9 @@
     register PERL_CONTEXT *cx;
     SV *sv;
 
+    if (CxMULTICALL(&cxstack[cxstack_ix]))
+	return 0;
+
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
 
diff -ru perl-current/pp_sort.c perl-hackery/pp_sort.c
--- perl-current/pp_sort.c	2005-10-14 00:31:31.000000000 +0100
+++ perl-hackery/pp_sort.c	2005-10-27 07:33:44.000000000 +0100
@@ -1542,14 +1542,8 @@
 
 	    if (is_xsub)
 		PL_sortcop = (OP*)cv;
-	    else {
+	    else
 		PL_sortcop = CvSTART(cv);
-		SAVEVPTR(CvROOT(cv)->op_ppaddr);
-		CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-
-		SAVECOMPPAD();
-		PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
-            }
 	}
     }
     else {
@@ -1574,6 +1568,10 @@
 	    }
 	}
 	else {
+	    if (SvREADONLY(av))
+		Perl_croak(aTHX_ PL_no_modify);
+	    else
+		SvREADONLY_on(av);
 	    p1 = p2 = AvARRAY(av);
 	    sorting_av = 1;
 	}
@@ -1645,13 +1643,12 @@
 	    CATCH_SET(TRUE);
 	    PUSHSTACKi(PERLSI_SORT);
 	    if (!hasargs && !is_xsub) {
-		if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
-		    SAVESPTR(PL_firstgv);
-		    SAVESPTR(PL_secondgv);
-		    PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
-		    PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
-		    PL_sortstash = stash;
-		}
+		SAVESPTR(PL_firstgv);
+		SAVESPTR(PL_secondgv);
+		SAVESPTR(PL_sortstash);
+		PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
+		PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
+		PL_sortstash = stash;
 		SAVESPTR(GvSV(PL_firstgv));
 		SAVESPTR(GvSV(PL_secondgv));
 	    }
@@ -1661,23 +1658,39 @@
 		cx->cx_type = CXt_SUB;
 		cx->blk_gimme = G_SCALAR;
 		PUSHSUB(cx);
-	    }
-	    PL_sortcxix = cxstack_ix;
+		if (!is_xsub) {
+		    AV* padlist = CvPADLIST(cv);
 
-	    if (hasargs && !is_xsub) {
-		/* This is mostly copied from pp_entersub */
-		AV *av = (AV*)PAD_SVl(0);
-
-		cx->blk_sub.savearray = GvAV(PL_defgv);
-		GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-		CX_CURPAD_SAVE(cx->blk_sub);
-		cx->blk_sub.argarray = av;
+		    if (++CvDEPTH(cv) >= 2) {
+			PERL_STACK_OVERFLOW_CHECK();
+			pad_push(padlist, CvDEPTH(cv));
+		    }
+		    SAVECOMPPAD();
+		    PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
+
+		    if (hasargs) {
+			/* This is mostly copied from pp_entersub */
+			AV *av = (AV*)PAD_SVl(0);
+
+			cx->blk_sub.savearray = GvAV(PL_defgv);
+			GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+			CX_CURPAD_SAVE(cx->blk_sub);
+			cx->blk_sub.argarray = av;
+		    }
+
+		}
 	    }
+	    cx->cx_type |= CXp_MULTICALL;
 	    
 	    start = p1 - max;
 	    sortsvp(aTHX_ start, max,
 		    is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 
+	    if (!(flags & OPf_SPECIAL)) {
+		LEAVESUB(cv);
+		if (!is_xsub)
+		    CvDEPTH(cv)--;
+	    }
 	    POPBLOCK(cx,PL_curpm);
 	    PL_stack_sp = newsp;
 	    POPSTACK;
@@ -1706,7 +1719,9 @@
 	    }
 	}
     }
-    if (av && !sorting_av) {
+    if (sorting_av)
+	SvREADONLY_off(av);
+    else if (av && !sorting_av) {
 	/* simulate pp_aassign of tied AV */
 	SV** const base = ORIGMARK+1;
 	for (i=0; i < max; i++) {
diff -ru perl-current/sv.c perl-hackery/sv.c
--- perl-current/sv.c	2005-10-26 10:02:35.000000000 +0100
+++ perl-hackery/sv.c	2005-10-27 07:33:44.000000000 +0100
@@ -3866,11 +3866,6 @@
 		GvNAMELEN(dstr) = len;
 		SvFAKE_on(dstr);	/* can coerce to non-glob */
 	    }
-	    /* ahem, death to those who redefine active sort subs */
-	    else if (PL_curstackinfo->si_type == PERLSI_SORT
-		     && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
-		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
-		      GvNAME(dstr));
 
 #ifdef GV_UNIQUE_CHECK
                 if (GvUNIQUE((GV*)dstr)) {
@@ -3973,13 +3968,6 @@
 			    if (!GvCVGEN((GV*)dstr) &&
 				(CvROOT(cv) || CvXSUB(cv)))
 			    {
-				/* ahem, death to those who redefine
-				 * active sort subs */
-				if (PL_curstackinfo->si_type == PERLSI_SORT &&
-				      PL_sortcop == CvSTART(cv))
-				    Perl_croak(aTHX_
-				    "Can't redefine active sort subroutine %s",
-					  GvENAME((GV*)dstr));
  				/* Redefining a sub - warning is mandatory if
  				   it was a const and its value changed. */
  				if (ckWARN(WARN_REDEFINE)
@@ -11908,7 +11896,6 @@
     PL_sortstash	= hv_dup(proto_perl->Tsortstash, param);
     PL_firstgv		= gv_dup(proto_perl->Tfirstgv, param);
     PL_secondgv		= gv_dup(proto_perl->Tsecondgv, param);
-    PL_sortcxix		= proto_perl->Tsortcxix;
     PL_efloatbuf	= Nullch;		/* reinits on demand */
     PL_efloatsize	= 0;			/* reinits on demand */
 
diff -ru perl-current/t/op/sort.t perl-hackery/t/op/sort.t
--- perl-current/t/op/sort.t	2004-07-28 07:52:50.000000000 +0100
+++ perl-hackery/t/op/sort.t	2005-10-28 10:06:04.000000000 +0100
@@ -5,7 +5,7 @@
     @INC = '../lib';
 }
 use warnings;
-print "1..129\n";
+print "1..141\n";
 
 # these shouldn't hang
 {
@@ -18,6 +18,7 @@
 
 sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+sub Backwards_other { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 
 my $upperfirst = 'A' lt 'a';
 
@@ -114,12 +115,12 @@
 print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n");
 print "# x = '@b'\n";
 
-# redefining sort sub inside the sort sub should fail
-sub twoface { *twoface = sub { $a <=> $b }; &twoface }
+# redefining sort sub inside the sort sub should not fail
+sub twoface { no warnings 'redefine'; *twoface = sub { $a <=> $b }; &twoface }
 eval { @b = sort twoface 4,1,3,2 };
-print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n");
+print ($@ eq '' ? "ok 17\n" : "not ok 17\n");
 
-# redefining sort subs outside the sort should not fail
+# redefining sort subs outside the sort should also not fail
 eval { no warnings 'redefine'; *twoface = sub { &Backwards } };
 print $@ ? "not ok 18\n" : "ok 18\n";
 
@@ -128,21 +129,22 @@
 
 {
   no warnings 'redefine';
-  *twoface = sub { *twoface = *Backwards; $a <=> $b };
+  *twoface = sub { *twoface = *Backwards_other; $a <=> $b };
 }
-eval { @b = sort twoface 4,1 };
-print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n");
+# The redefinition should not take effect during the sort
+eval { @b = sort twoface 4,1,9,5 };
+print (($@ eq "" && "@b" eq "1 4 5 9") ? "ok 20\n" : "not ok 20 # $@|@b\n");
 
 {
   no warnings 'redefine';
   *twoface = sub {
                  eval 'sub twoface { $a <=> $b }';
-		 die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n");
+		 die($@ eq "" ? "ok 21\n" : "not ok 21\n");
 		 $a <=> $b;
 	       };
 }
 eval { @b = sort twoface 4,1 };
-print $@ ? "$@" : "not ok 21\n";
+print($@ ? "$@" : "not ok 21 # $@\n");
 
 eval <<'CODE';
     my @result = sort main'Backwards 'one', 'two';
@@ -670,3 +672,117 @@
 
 @output = reverse (0, sort(qw(C A B)));
 ok "@output", "C B A 0", 'reversed sort with leading argument';
+
+eval { @output = sort {goto sub {}} 1,2; };
+print(($@ =~ /^Can't goto subroutine outside a subroutine/ ?
+	"ok " :
+	"not ok "),
+	$test++, " # $@");
+
+sub goto_sub {goto sub{}}
+eval { @output = sort goto_sub 1,2; };
+print(($@ =~ /^Can't goto subroutine from a sort sub/ ?
+	"ok " :
+	"not ok "),
+	$test++, " # $@");
+
+eval { @output = sort {goto label} 1,2; };
+print(($@ =~ /^Can't "goto" out of a pseudo block/ ?
+	"ok " :
+	"not ok "),
+	$test++, " # $@");
+
+sub goto_label {goto label}
+label: eval { @output = sort goto_label 1,2; };
+print(($@ =~ /^Can't "goto" out of a pseudo block/ ?
+	"ok " :
+	"not ok "),
+	$test++, " # $@");
+
+sub self_immolate {undef &self_immolate; $a<=>$b}
+eval { @output = sort self_immolate 1,2,3 };
+print(($@ =~ /^Can't undef active subroutine/ ?
+	"ok " :
+	"not ok "),
+	$test++, " # $@");
+
+{
+    my $failed = 0;
+
+    sub rec {
+	my $n = shift;
+	if (!defined($n)) {  # No arg means we're being called by sort()
+	    return 1;
+	}
+	if ($n<5) { rec($n+1); }
+	else { () = sort rec 1,2; }
+
+	$failed = 1 if !defined $n;
+    }
+
+    rec(1);
+    print((!$failed ? "ok " : "not ok "), $test++, " - sort from active sub\n");
+}
+
+# $a and $b are set in the package the sort() is called from,
+# *not* the package the sort sub is in. This is longstanding
+# de facto behaviour that shouldn't be broken.
+package main;
+my $answer = "ok ";
+() = sort OtherPack::foo 1,2,3,4;
+
+{package OtherPack; sub foo {
+  $answer = "not ok " if
+    defined($a) || defined($b) || !defined($main::a) || !defined($main::b);
+  $main::a <=> $main::b;
+}}
+
+print $answer, $test++, "\n";
+
+
+# Bug 36430 - sort called in package2 while a
+# sort in package1 is active should set $package2::a/b.
+
+$answer = "ok ";
+my @list = sort { A::min(@$a) <=> A::min(@$b) }
+  [3, 1, 5], [2, 4], [0];
+
+print $answer, $test++, "\n";
+
+package A;
+sub min {
+  my @list = sort {
+    $answer = "not ok " if !defined($a) || !defined($b);
+    $a <=> $b;
+  } @_;
+  $list[0];
+}
+
+# Bug 7567 - an array shouldn't be modifiable while it's being
+# sorted in-place.
+eval { @a=(1..8); @a = sort { @a = (0) } @a; };
+
+print(($@ =~ /^Modification of a read-only value attempted/ ?
+	"ok " :
+	"not ok "),
+	$test++, " # $@");
+
+# Sorting shouldn't increase the refcount of a sub
+sub foo {(1+$a) <=> (1+$b)}
+my $refcnt = &Internals::SvREFCNT(\&foo);
+@output = sort foo 3,7,9;
+package Foo;
+ok($refcnt, &Internals::SvREFCNT(\&foo), "sort sub refcnt");
+
+# Sorting a read-only array in-place shouldn't be allowed
+my @readonly = (1..10);
+Internals::SvREADONLY(@readonly, 1);
+eval { @readonly = sort @readonly; };
+print(($@ =~ /^Modification of a read-only value attempted/ ?
+	"ok " :
+	"not ok "),
+	$test++, " # $@");
+
+# Using return() should be okay even in a deeper context
+@b = sort {while (1) {return ($a <=> $b)} } 1..10;
+ok("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop");
diff -ru perl-current/t/op/threads.t perl-hackery/t/op/threads.t
--- perl-current/t/op/threads.t	2004-06-25 09:57:48.000000000 +0100
+++ perl-hackery/t/op/threads.t	2005-10-27 07:33:44.000000000 +0100
@@ -17,7 +17,7 @@
        print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
        exit 0;
      }
-     plan(3);
+     plan(4);
 }
 use threads;
 
@@ -59,3 +59,39 @@
 threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
 print "ok";
 EOI
+
+#PR30333 - sort() crash with threads
+sub mycmp { length($b) <=> length($a) }
+
+sub do_sort_one_thread {
+   my $kid = shift;
+   print "# kid $kid before sort\n";
+   my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
+                'hello', 's', 'thisisalongname', '1', '2', '3',
+                'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
+
+   for my $j (1..99999) {
+      for my $k (sort mycmp @list) {}
+   }
+   print "# kid $kid after sort, sleeping 1\n";
+   sleep(1);
+   print "# kid $kid exit\n";
+}
+
+sub do_sort_threads {
+   my $nthreads = shift;
+   my @kids = ();
+   for my $i (1..$nthreads) {
+      my $t = threads->new(\&do_sort_one_thread, $i);
+      print "# parent $$: continue\n";
+      push(@kids, $t);
+   }
+   for my $t (@kids) {
+      print "# parent $$: waiting for join\n";
+      $t->join();
+      print "# parent $$: thread exited\n";
+   }
+}
+
+do_sort_threads(2);        # crashes
+ok(1);
diff -ru perl-current/thrdvar.h perl-hackery/thrdvar.h
--- perl-current/thrdvar.h	2005-06-02 09:07:41.000000000 +0100
+++ perl-hackery/thrdvar.h	2005-10-27 07:33:44.000000000 +0100
@@ -147,7 +147,6 @@
 PERLVAR(Tsortstash,	HV *)		/* which is in some package or other */
 PERLVAR(Tfirstgv,	GV *)		/* $a */
 PERLVAR(Tsecondgv,	GV *)		/* $b */
-PERLVAR(Tsortcxix,	I32)		/* from pp_ctl.c */
 
 /* float buffer */
 PERLVAR(Tefloatbuf,	char*)

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About