X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=34e18b5f32e029fa2b3c764e93aa79e2a3344143;hb=2decb4fb82e001e3c9671c57b61232c651a9c22c;hp=b1f71a38190dac71123d692e93af334bd70f9628;hpb=7766f1371a6d2b58d0f46fbe6a60785860a39c1e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index b1f71a3..34e18b5 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;
 }
@@ -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;
@@ -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);
-	    SAVEVPTR(CvROOT(cv)->op_ppaddr);
-	    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 
-	    SAVEVPTR(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");
@@ -1645,7 +1676,11 @@ PP(pp_enteriter)
 	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");
@@ -1836,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);
@@ -1914,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);
@@ -1939,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);
@@ -2318,7 +2353,7 @@ PP(pp_goto)
 		/* 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");
@@ -2394,6 +2429,7 @@ PP(pp_exit)
 	    anum = 0;
 #endif
     }
+    PL_exit_flags |= PERL_EXIT_EXPECTED;
     my_exit(anum);
     PUSHs(&PL_sv_undef);
     RETURN;
@@ -2804,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);
@@ -4147,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)