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

Sort / multicall patch: second draft

Thread Next
From:
Robin Houston
Date:
October 26, 2005 10:39
Subject:
Sort / multicall patch: second draft
Message ID:
20051026173901.GA3105@rpc142.cs.man.ac.uk
The second draft of the sort/multicall patch. It still needs
documentation and some List::Util work (i.e. testing and
backwards compatibility).

This patch additionally fixes bugs 7567 and 36430.

There is still a bug as follows:

$ ./perl -e '@a=(1..10); @b = sort {@a=();1} @a'
semi-panic: attempt to dup freed string at -e line 1.
semi-panic: attempt to dup freed string at -e line 1.
semi-panic: attempt to dup freed string at -e line 1.
semi-panic: attempt to dup freed string at -e line 1.
semi-panic: attempt to dup freed string at -e line 1.

which I don't yet completely understand. Of course the
elements of @a are being freed when the array is
redefined, and then the aassign tries to copy the
freed elements - I can see that much. But this isn't
ordinarily a problem: e.g.

  $ ./perl -e '@a=(1..10); @b = (@a,(@a=())); print @b'

doesn't cause this error. I guess it's because the
values are mortalised rather than SvREFCNT_dec()ed
straight away, and the mortals aren't cleared out
until later; whereas in the sort case they are. Is
there any way to defer their destruction until the
end of the statement that the sort() is in?

Robin



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-25 23:50:58.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	0x00000100	/* 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 & (CXt_SUB|CXt_NULL|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,62 @@
 #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; 
+
+#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-24 22:48:54.000000000 +0100
+++ perl-hackery/embed.fnc	2005-10-25 23:51:45.000000000 +0100
@@ -1416,7 +1416,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-26 00:03:47.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-25 23:48:32.000000000 +0100
@@ -230,52 +230,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;
 
     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);
     for(index = 2 ; index < items ; index++) {
 	GvSV(bgv) = ST(index);
-	PL_op = reducecop;
-	CALLRUNOPS(aTHX);
+	MULTICALL;
 	SvSetSV(ret, *PL_stack_sp);
     }
+    POP_MULTICALL;
     ST(0) = ret;
-    POPBLOCK(cx,PL_curpm);
-    CATCH_SET(oldcatch);
     XSRETURN(1);
 }
 
@@ -285,51 +265,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;
 
     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);
+	MULTICALL;
 	if (SvTRUE(*PL_stack_sp)) {
 	  ST(0) = ST(index);
-	  POPBLOCK(cx,PL_curpm);
-	  CATCH_SET(oldcatch);
+	  POP_MULTICALL;
 	  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-25 20:34:33.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/global.sym perl-hackery/global.sym
--- perl-current/global.sym	2005-10-24 22:48:54.000000000 +0100
+++ perl-hackery/global.sym	2005-10-26 00:03:46.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-24 22:48:54.000000000 +0100
+++ perl-hackery/makedef.pl	2005-10-26 00:01:49.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-25 18:44:05.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-06-29 09:41:56.000000000 +0100
+++ perl-hackery/perlapi.h	2005-10-26 00:03:47.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/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-26 00:58:43.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-26 00:55:56.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-25 18:44:05.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-26 17:20:17.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-19 09:46:59.000000000 +0100
+++ perl-hackery/sv.c	2005-10-26 00:02: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)
@@ -11906,7 +11894,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-26 18:23:17.000000000 +0100
@@ -5,7 +5,7 @@
     @INC = '../lib';
 }
 use warnings;
-print "1..129\n";
+print "1..138\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,97 @@
 
 @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++, " # $@");
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-26 02:07:37.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-26 00:03:43.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