perl 5.003_01: pp_ctl.c

Rename global variable to eliminate collision with system header files
Allow redurection of debug messages
Make sure the right stack is in use in die()
Correct juggling of stack and @_ in pp_goto()
Get more information about XSUBs to debugger
Preserve SP around eval
Propagate G_KEEPERR down into eval
Don't worry about %INC if we're not in a "require"

1 files changed, 42 insertions, 19 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index e57e88a167..0e86fd132b 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -621,13 +621,13 @@ PP(pp_sort)
 	    SAVETMPS;
 	    SAVESPTR(op);
 
-	    oldstack = stack;
+	    oldstack = curstack;
 	    if (!sortstack) {
 		sortstack = newAV();
 		AvREAL_off(sortstack);
 		av_extend(sortstack, 32);
 	    }
-	    SWITCHSTACK(stack, sortstack);
+	    SWITCHSTACK(curstack, sortstack);
 	    if (sortstash != stash) {
 		firstgv = gv_fetchpv("a", TRUE, SVt_PV);
 		secondgv = gv_fetchpv("b", TRUE, SVt_PV);
@@ -881,7 +881,7 @@ I32 cxix;
 
     while (cxstack_ix > cxix) {
 	cx = &cxstack[cxstack_ix--];
-	DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
+	DEBUG_l(fprintf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
 		    block_type[cx->cx_type]));
 	/* Note: we don't need to restore the base context info till the end. */
 	switch (cx->cx_type) {
@@ -919,6 +919,13 @@ die(pat, va_alist)
     GV *gv;
     CV *cv;
 
+    /* We have to switch back to mainstack or die_where may try to pop
+     * the eval block from the wrong stack if die is being called from a
+     * signal handler.  - dkindred@cs.cmu.edu */
+    if (curstack != mainstack) {
+        dSP;
+        SWITCHSTACK(curstack, mainstack);
+    }
 #ifdef I_STDARG
     va_start(args, pat);
 #else
@@ -1308,8 +1315,8 @@ PP(pp_enteriter)
 	cx->blk_loop.iterix = -1;
     }
     else {
-	cx->blk_loop.iterary = stack;
-	AvFILL(stack) = sp - stack_base;
+	cx->blk_loop.iterary = curstack;
+	AvFILL(curstack) = sp - stack_base;
 	cx->blk_loop.iterix = MARK - stack_base;
     }
 
@@ -1376,11 +1383,11 @@ PP(pp_return)
     PMOP *newpm;
     I32 optype = 0;
 
-    if (stack == sortstack) {
+    if (curstack == sortstack) {
 	if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
 	    if (cxstack_ix > sortcxix)
 		dounwind(sortcxix);
-	    AvARRAY(stack)[1] = *SP;
+	    AvARRAY(curstack)[1] = *SP;
 	    stack_sp = stack_base + 1;
 	    return 0;
 	}
@@ -1634,7 +1641,9 @@ PP(pp_goto)
 		AV* av = cx->blk_sub.argarray;
 		
 		items = AvFILL(av) + 1;
-		Copy(AvARRAY(av), ++stack_sp, items, SV*);
+		stack_sp++;
+		EXTEND(stack_sp, items); /* @_ could have been extended. */
+		Copy(AvARRAY(av), stack_sp, items, SV*);
 		stack_sp += items;
 		GvAV(defgv) = cx->blk_sub.savearray;
 		AvREAL_off(av);
@@ -1661,6 +1670,7 @@ PP(pp_goto)
 		    sp = stack_base + items;
 		}
 		else {
+		    stack_sp--;		/* There is no cv arg. */
 		    (void)(*CvXSUB(cv))(cv);
 		}
 		LEAVE;
@@ -1750,6 +1760,13 @@ PP(pp_goto)
 			mark++;
 		    }
 		}
+		if (perldb && curstash != debstash) { /* &xsub is not copying @_ */
+		    SV *sv = GvSV(DBsub);
+		    save_item(sv);
+		    gv_efullname(sv, CvGV(cv)); /* We do not care about
+						 * using sv to call CV,
+						 * just for info. */
+		}
 		RETURNOP(CvSTART(cv));
 	    }
 	}
@@ -1843,7 +1860,7 @@ PP(pp_goto)
 	do_undump = FALSE;
     }
 
-    if (stack == signalstack) {
+    if (curstack == signalstack) {
         restartop = retop;
         Siglongjmp(top_env, 3);
     }
@@ -1944,6 +1961,8 @@ int gimme;
 
     in_eval = 1;
 
+    PUSHMARK(SP);
+
     /* set up a scratch pad */
 
     SAVEINT(padix);
@@ -1992,7 +2011,10 @@ int gimme;
     curcop->cop_arybase = 0;
     SvREFCNT_dec(rs);
     rs = newSVpv("\n", 1);
-    sv_setpv(GvSV(errgv),"");
+    if (saveop->op_flags & OPf_SPECIAL)
+	in_eval |= 4;
+    else
+	sv_setpv(GvSV(errgv),"");
     if (yyparse() || error_count || !eval_root) {
 	SV **newsp;
 	I32 gimme;
@@ -2004,6 +2026,7 @@ int gimme;
 	    op_free(eval_root);
 	    eval_root = Nullop;
 	}
+	SP = stack_base + POPMARK;		/* pop original mark */
 	POPBLOCK(cx,curpm);
 	POPEVAL(cx);
 	pop_return();
@@ -2028,6 +2051,7 @@ int gimme;
 
     /* compiled okay, so do it */
 
+    SP = stack_base + POPMARK;		/* pop original mark */
     RETURNOP(eval_start);
 }
 
@@ -2201,6 +2225,7 @@ PP(pp_leaveeval)
     I32 gimme;
     register CONTEXT *cx;
     OP *retop;
+    OP *saveop = op;
     I32 optype;
 
     POPBLOCK(cx,newpm);
@@ -2233,21 +2258,19 @@ PP(pp_leaveeval)
     }
     curpm = newpm;	/* Don't pop $1 et al till now */
 
-    if (optype != OP_ENTEREVAL) {
+    if (optype == OP_REQUIRE &&
+	!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
 	char *name = cx->blk_eval.old_name;
 
-	if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
-	    /* Unassume the success we assumed earlier. */
-	    (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
-
-	    if (optype == OP_REQUIRE)
-		retop = die("%s did not return a true value", name);
-	}
+	/* Unassume the success we assumed earlier. */
+	(void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
+	retop = die("%s did not return a true value", name);
     }
 
     lex_end();
     LEAVE;
-    sv_setpv(GvSV(errgv),"");
+    if (!(saveop->op_flags & OPf_SPECIAL))
+	sv_setpv(GvSV(errgv),"");
 
     RETURNOP(retop);
 }