1 files changed, 238 insertions, 44 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index bc2a361267..34e18b5f32 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -27,6 +27,8 @@
 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
 
 static I32 sortcv(pTHXo_ SV *a, SV *b);
+static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
+static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
@@ -132,9 +134,13 @@ PP(pp_regcomp)
     else if (strEQ("\\s+", pm->op_pmregexp->precomp))
 	pm->op_pmflags |= PMf_WHITE;
 
+    /* XXX runtime compiled output needs to move to the pad */
     if (pm->op_pmflags & PMf_KEEP) {
 	pm->op_private &= ~OPpRUNTIME;	/* no point compiling again */
+#if !defined(USE_ITHREADS) && !defined(USE_THREADS)
+	/* XXX can't change the optree at runtime either */
 	cLOGOP->op_first->op_next = PL_op->op_next;
+#endif
     }
     RETURN;
 }
@@ -686,7 +692,7 @@ PP(pp_grepstart)
     /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
     SAVESPTR(DEFSV);
     ENTER;					/* enter inner scope */
-    SAVESPTR(PL_curpm);
+    SAVEVPTR(PL_curpm);
 
     src = PL_stack_base[*PL_markstack_ptr];
     SvTEMP_off(src);
@@ -756,7 +762,7 @@ PP(pp_mapwhile)
 	SV *src;
 
 	ENTER;					/* enter inner scope */
-	SAVESPTR(PL_curpm);
+	SAVEVPTR(PL_curpm);
 
 	src = PL_stack_base[PL_markstack_ptr[-1]];
 	SvTEMP_off(src);
@@ -778,6 +784,8 @@ PP(pp_sort)
     I32 gimme = GIMME;
     OP* nextop = PL_op->op_next;
     I32 overloading = 0;
+    bool hasargs = FALSE;
+    I32 is_xsub = 0;
 
     if (gimme != G_ARRAY) {
 	SP = MARK;
@@ -785,7 +793,7 @@ PP(pp_sort)
     }
 
     ENTER;
-    SAVEPPTR(PL_sortcop);
+    SAVEVPTR(PL_sortcop);
     if (PL_op->op_flags & OPf_STACKED) {
 	if (PL_op->op_flags & OPf_SPECIAL) {
 	    OP *kid = cLISTOP->op_first->op_sibling;	/* pass pushmark */
@@ -796,28 +804,38 @@ PP(pp_sort)
 	}
 	else {
 	    cv = sv_2cv(*++MARK, &stash, &gv, 0);
+	    if (cv && SvPOK(cv)) {
+		STRLEN n_a;
+		char *proto = SvPV((SV*)cv, n_a);
+		if (proto && strEQ(proto, "$$")) {
+		    hasargs = TRUE;
+		}
+	    }
 	    if (!(cv && CvROOT(cv))) {
-		if (gv) {
+		if (cv && CvXSUB(cv)) {
+		    is_xsub = 1;
+		}
+		else if (gv) {
 		    SV *tmpstr = sv_newmortal();
 		    gv_efullname3(tmpstr, gv, Nullch);
-		    if (cv && CvXSUB(cv))
-			DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
 		    DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
 			SvPVX(tmpstr));
 		}
-		if (cv) {
-		    if (CvXSUB(cv))
-			DIE(aTHX_ "Xsub called in sort");
+		else {
 		    DIE(aTHX_ "Undefined subroutine in sort");
 		}
-		DIE(aTHX_ "Not a CODE reference in sort");
 	    }
-	    PL_sortcop = CvSTART(cv);
-	    SAVESPTR(CvROOT(cv)->op_ppaddr);
-	    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 
-	    SAVESPTR(PL_curpad);
-	    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+	    if (is_xsub)
+		PL_sortcop = (OP*)cv;
+	    else {
+		PL_sortcop = CvSTART(cv);
+		SAVEVPTR(CvROOT(cv)->op_ppaddr);
+		CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+
+		SAVEVPTR(PL_curpad);
+		PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+            }
 	}
     }
     else {
@@ -863,7 +881,6 @@ PP(pp_sort)
 
 	    PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
 	    if (!(PL_op->op_flags & OPf_SPECIAL)) {
-		bool hasargs = FALSE;
 		cx->cx_type = CXt_SUB;
 		cx->blk_gimme = G_SCALAR;
 		PUSHSUB(cx);
@@ -871,7 +888,19 @@ PP(pp_sort)
 		    (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
 	    }
 	    PL_sortcxix = cxstack_ix;
-	    qsortsv((myorigmark+1), max, sortcv);
+
+	    if (hasargs && !is_xsub) {
+		/* This is mostly copied from pp_entersub */
+		AV *av = (AV*)PL_curpad[0];
+
+#ifndef USE_THREADS
+		cx->blk_sub.savearray = GvAV(PL_defgv);
+		GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+		cx->blk_sub.argarray = av;
+	    }
+	    qsortsv((myorigmark+1), max,
+		    is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 
 	    POPBLOCK(cx,PL_curpm);
 	    PL_stack_sp = newsp;
@@ -968,7 +997,9 @@ PP(pp_flop)
 	    mg_get(right);
 
 	if (SvNIOKp(left) || !SvPOKp(left) ||
-	  (looks_like_number(left) && *SvPVX(left) != '0') )
+	    SvNIOKp(right) || !SvPOKp(right) ||
+	    (looks_like_number(left) && *SvPVX(left) != '0' &&
+	     looks_like_number(right) && *SvPVX(right) != '0'))
 	{
 	    if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
 		DIE(aTHX_ "Range iterator outside integer range");
@@ -1040,6 +1071,11 @@ S_dopoptolabel(pTHX_ char *label)
 		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
+	case CXt_FORMAT:
+	    if (ckWARN(WARN_UNSAFE))
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+			PL_op_name[PL_op->op_type]);
+	    break;
 	case CXt_EVAL:
 	    if (ckWARN(WARN_UNSAFE))
 		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
@@ -1115,6 +1151,7 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
 	    continue;
 	case CXt_EVAL:
 	case CXt_SUB:
+	case CXt_FORMAT:
 	    DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
 	    return i;
 	}
@@ -1160,6 +1197,11 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
+	case CXt_FORMAT:
+	    if (ckWARN(WARN_UNSAFE))
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+			PL_op_name[PL_op->op_type]);
+	    break;
 	case CXt_EVAL:
 	    if (ckWARN(WARN_UNSAFE))
 		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
@@ -1208,6 +1250,9 @@ Perl_dounwind(pTHX_ I32 cxix)
 	    break;
 	case CXt_NULL:
 	    break;
+	case CXt_FORMAT:
+	    POPFORMAT(cx);
+	    break;
 	}
 	cxstack_ix--;
     }
@@ -1420,7 +1465,7 @@ PP(pp_caller)
     }
 
     cx = &ccstack[cxix];
-    if (CxTYPE(cx) == CXt_SUB) {
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
         dbcxix = dopoptosub_at(ccstack, cxix - 1);
 	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
 	   field below is defined for any cx. */
@@ -1448,7 +1493,8 @@ PP(pp_caller)
     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
     if (!MAXARG)
 	RETURN;
-    if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+	/* So is ccstack[dbcxix]. */
 	sv = NEWSV(49, 0);
 	gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
 	PUSHs(sv_2mortal(sv));
@@ -1563,7 +1609,7 @@ PP(pp_dbstate)
 	PUSHSUB(cx);
 	CvDEPTH(cv)++;
 	(void)SvREFCNT_inc(cv);
-	SAVESPTR(PL_curpad);
+	SAVEVPTR(PL_curpad);
 	PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
 	RETURNOP(CvSTART(cv));
     }
@@ -1582,6 +1628,10 @@ PP(pp_enteriter)
     register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
     SV **svp;
+    U32 cxtype = CXt_LOOP;
+#ifdef USE_ITHREADS
+    void *iterdata;
+#endif
 
     ENTER;
     SAVETMPS;
@@ -1598,23 +1648,39 @@ PP(pp_enteriter)
     if (PL_op->op_targ) {
 	svp = &PL_curpad[PL_op->op_targ];		/* "my" variable */
 	SAVESPTR(*svp);
+#ifdef USE_ITHREADS
+	iterdata = (void*)PL_op->op_targ;
+	cxtype |= CXp_PADVAR;
+#endif
     }
     else {
-	svp = &GvSV((GV*)POPs);			/* symbol table variable */
+	GV *gv = (GV*)POPs;
+	svp = &GvSV(gv);			/* symbol table variable */
 	SAVEGENERICSV(*svp);
 	*svp = NEWSV(0,0);
+#ifdef USE_ITHREADS
+	iterdata = (void*)gv;
+#endif
     }
 
     ENTER;
 
-    PUSHBLOCK(cx, CXt_LOOP, SP);
+    PUSHBLOCK(cx, cxtype, SP);
+#ifdef USE_ITHREADS
+    PUSHLOOP(cx, iterdata, MARK);
+#else
     PUSHLOOP(cx, svp, MARK);
+#endif
     if (PL_op->op_flags & OPf_STACKED) {
 	cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
 	if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
 	    dPOPss;
 	    if (SvNIOKp(sv) || !SvPOKp(sv) ||
-		(looks_like_number(sv) && *SvPVX(sv) != '0')) {
+		SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
+		(looks_like_number(sv) && *SvPVX(sv) != '0' &&
+		 looks_like_number((SV*)cx->blk_loop.iterary) &&
+		 *SvPVX(cx->blk_loop.iterary) != '0'))
+	    {
 		 if (SvNV(sv) < IV_MIN ||
 		     SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
 		     DIE(aTHX_ "Range iterator outside integer range");
@@ -1703,7 +1769,9 @@ PP(pp_return)
     SV *sv;
 
     if (PL_curstackinfo->si_type == PERLSI_SORT) {
-	if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
+	if (cxstack_ix == PL_sortcxix
+	    || dopoptosub(cxstack_ix) <= PL_sortcxix)
+	{
 	    if (cxstack_ix > PL_sortcxix)
 		dounwind(PL_sortcxix);
 	    AvARRAY(PL_curstack)[1] = *SP;
@@ -1737,6 +1805,9 @@ PP(pp_return)
 	    DIE(aTHX_ "%s did not return a true value", name);
 	}
 	break;
+    case CXt_FORMAT:
+	POPFORMAT(cx);
+	break;
     default:
 	DIE(aTHX_ "panic: return");
     }
@@ -1800,7 +1871,7 @@ PP(pp_last)
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
 	if (cxix < 0)
-	    DIE(aTHX_ "Can't \"last\" outside a block");
+	    DIE(aTHX_ "Can't \"last\" outside a loop block");
     }
     else {
 	cxix = dopoptolabel(cPVOP->op_pv);
@@ -1826,6 +1897,10 @@ PP(pp_last)
 	POPEVAL(cx);
 	nextop = pop_return();
 	break;
+    case CXt_FORMAT:
+	POPFORMAT(cx);
+	nextop = pop_return();
+	break;
     default:
 	DIE(aTHX_ "panic: last");
     }
@@ -1874,7 +1949,7 @@ PP(pp_next)
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
 	if (cxix < 0)
-	    DIE(aTHX_ "Can't \"next\" outside a block");
+	    DIE(aTHX_ "Can't \"next\" outside a loop block");
     }
     else {
 	cxix = dopoptolabel(cPVOP->op_pv);
@@ -1899,7 +1974,7 @@ PP(pp_redo)
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
 	if (cxix < 0)
-	    DIE(aTHX_ "Can't \"redo\" outside a block");
+	    DIE(aTHX_ "Can't \"redo\" outside a loop block");
     }
     else {
 	cxix = dopoptolabel(cPVOP->op_pv);
@@ -2072,7 +2147,7 @@ PP(pp_goto)
 			SP[1] = SP[0];
 			SP--;
 		    }
-		    fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
+		    fp3 = (I32(*)(int,int,int))CvXSUB(cv);
 		    items = (*fp3)(CvXSUBANY(cv).any_i32,
 		                   mark - PL_stack_base + 1,
 				   items);
@@ -2116,9 +2191,10 @@ PP(pp_goto)
 			AV *newpad = newAV();
 			SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
 			I32 ix = AvFILLp((AV*)svp[1]);
+			I32 names_fill = AvFILLp((AV*)svp[0]);
 			svp = AvARRAY(svp[0]);
 			for ( ;ix > 0; ix--) {
-			    if (svp[ix] != &PL_sv_undef) {
+			    if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
 				char *name = SvPVX(svp[ix]);
 				if ((SvFLAGS(svp[ix]) & SVf_FAKE)
 				    || *name == '&')
@@ -2137,7 +2213,7 @@ PP(pp_goto)
 				    SvPADMY_on(sv);
 				}
 			    }
-			    else if (IS_PADGV(oldpad[ix])) {
+			    else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
 				av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
 			    }
 			    else {
@@ -2170,7 +2246,7 @@ PP(pp_goto)
 		    }
 		}
 #endif /* USE_THREADS */		
-		SAVESPTR(PL_curpad);
+		SAVEVPTR(PL_curpad);
 		PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
 #ifndef USE_THREADS
 		if (cx->blk_sub.hasargs)
@@ -2275,8 +2351,9 @@ PP(pp_goto)
 		    break;
 		}
 		/* FALL THROUGH */
+	    case CXt_FORMAT:
 	    case CXt_NULL:
-		DIE(aTHX_ "Can't \"goto\" outside a block");
+		DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
 	    default:
 		if (ix)
 		    DIE(aTHX_ "panic: goto");
@@ -2352,6 +2429,7 @@ PP(pp_exit)
 	    anum = 0;
 #endif
     }
+    PL_exit_flags |= PERL_EXIT_EXPECTED;
     my_exit(anum);
     PUSHs(&PL_sv_undef);
     RETURN;
@@ -2506,7 +2584,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
 #ifdef OP_IN_REGISTER
     PL_opsave = op;
 #else
-    SAVEPPTR(PL_op);
+    SAVEVPTR(PL_op);
 #endif
     PL_hints = 0;
 
@@ -2549,7 +2627,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
     /* set up a scratch pad */
 
     SAVEI32(PL_padix);
-    SAVESPTR(PL_curpad);
+    SAVEVPTR(PL_curpad);
     SAVESPTR(PL_comppad);
     SAVESPTR(PL_comppad_name);
     SAVEI32(PL_comppad_name_fill);
@@ -2561,7 +2639,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
 	PERL_CONTEXT *cx = &cxstack[i];
 	if (CxTYPE(cx) == CXt_EVAL)
 	    break;
-	else if (CxTYPE(cx) == CXt_SUB) {
+	else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
 	    caller = cx->blk_sub.cv;
 	    break;
 	}
@@ -2762,10 +2840,54 @@ PP(pp_require)
     SV *filter_sub = 0;
 
     sv = POPs;
-    if (SvNIOKp(sv) && !SvPOKp(sv)) {
-	if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
-	    DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
-		SvPV(sv,n_a),PL_patchlevel);
+    if (SvNIOKp(sv)) {
+	UV rev, ver, sver;
+	if (SvPOKp(sv) && SvUTF8(sv)) {		/* require v5.6.1 */
+	    I32 len;
+	    U8 *s = (U8*)SvPVX(sv);
+	    U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
+	    if (s < end) {
+		rev = utf8_to_uv(s, &len);
+		s += len;
+		if (s < end) {
+		    ver = utf8_to_uv(s, &len);
+		    s += len;
+		    if (s < end)
+			sver = utf8_to_uv(s, &len);
+		    else
+			sver = 0;
+		}
+		else
+		    ver = 0;
+	    }
+	    else
+		rev = 0;
+	    if (PERL_REVISION < rev
+		|| (PERL_REVISION == rev
+		    && (PERL_VERSION < ver
+			|| (PERL_VERSION == ver
+			    && PERL_SUBVERSION < sver))))
+	    {
+		DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
+		    "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
+		    PERL_VERSION, PERL_SUBVERSION);
+	    }
+	}
+	else if (!SvPOKp(sv)) {			/* require 5.005_03 */
+	    NV n = SvNV(sv);
+	    rev = (UV)n;
+	    ver = (UV)((n-rev)*1000);
+	    sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
+
+	    if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
+		+ ((NV)PERL_SUBVERSION/(NV)1000000)
+		+ 0.00000099 < SvNV(sv))
+	    {
+		DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
+		    "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
+		    PERL_VERSION, PERL_SUBVERSION);
+	    }
+	}
 	RETPUSHYES;
     }
     name = SvPV(sv, len);
@@ -2970,11 +3092,9 @@ PP(pp_require)
     PL_rsfp_filters = Nullav;
 
     PL_rsfp = tryrsfp;
-    name = savepv(name);
-    SAVEFREEPV(name);
     SAVEHINTS();
     PL_hints = 0;
-    SAVEPPTR(PL_compiling.cop_warnings);
+    SAVESPTR(PL_compiling.cop_warnings);
     if (PL_dowarn & G_WARN_ALL_ON)
         PL_compiling.cop_warnings = WARN_ALL ;
     else if (PL_dowarn & G_WARN_ALL_OFF)
@@ -3049,7 +3169,7 @@ PP(pp_entereval)
     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
     SAVEHINTS();
     PL_hints = PL_op->op_targ;
-    SAVEPPTR(PL_compiling.cop_warnings);
+    SAVESPTR(PL_compiling.cop_warnings);
     if (!specialWARN(PL_compiling.cop_warnings)) {
         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
         SAVEFREESV(PL_compiling.cop_warnings) ;
@@ -4107,6 +4227,80 @@ sortcv(pTHXo_ SV *a, SV *b)
     return result;
 }
 
+static I32
+sortcv_stacked(pTHXo_ SV *a, SV *b)
+{
+    dTHR;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    AV *av;
+
+#ifdef USE_THREADS
+    av = (AV*)PL_curpad[0];
+#else
+    av = GvAV(PL_defgv);
+#endif
+
+    if (AvMAX(av) < 1) {
+	SV** ary = AvALLOC(av);
+	if (AvARRAY(av) != ary) {
+	    AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+	    SvPVX(av) = (char*)ary;
+	}
+	if (AvMAX(av) < 1) {
+	    AvMAX(av) = 1;
+	    Renew(ary,2,SV*);
+	    SvPVX(av) = (char*)ary;
+	}
+    }
+    AvFILLp(av) = 1;
+
+    AvARRAY(av)[0] = a;
+    AvARRAY(av)[1] = b;
+    PL_stack_sp = PL_stack_base;
+    PL_op = PL_sortcop;
+    CALLRUNOPS(aTHX);
+    if (PL_stack_sp != PL_stack_base + 1)
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+	LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
+static I32
+sortcv_xsub(pTHXo_ SV *a, SV *b)
+{
+    dSP;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    CV *cv=(CV*)PL_sortcop;
+
+    SP = PL_stack_base;
+    PUSHMARK(SP);
+    EXTEND(SP, 2);
+    *++SP = a;
+    *++SP = b;
+    PUTBACK;
+    (void)(*CvXSUB(cv))(aTHXo_ cv);
+    if (PL_stack_sp != PL_stack_base + 1)
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+	LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
 
 static I32
 sv_ncmp(pTHXo_ SV *a, SV *b)