X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=371e037ae525e6b28365f5128e99faaa72dae8af;hb=10a676f83f541430b63a3192b246bf6f86d3b189;hp=1f558f72841f6a94b01bae1ae76f84402a5e59fa;hpb=a5f75d667838e8e7bb037880391f5c44476d33b4;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 1f558f7..371e037 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-1994, Larry Wall
+ *    Copyright (c) 1991-1997, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -23,6 +23,9 @@
 #define WORD_ALIGN sizeof(U16)
 #endif
 
+#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
 static OP *doeval _((int gimme));
 static OP *dofindlabel _((OP *op, char *label, OP **opstack));
 static void doparseform _((SV *sv));
@@ -31,8 +34,9 @@ static I32 dopoptolabel _((char *label));
 static I32 dopoptoloop _((I32 startingblock));
 static I32 dopoptosub _((I32 startingblock));
 static void save_lines _((AV *array, SV *sv));
-static int sortcmp _((const void *, const void *));
 static int sortcv _((const void *, const void *));
+static int sortcmp _((const void *, const void *));
+static int sortcmp_locale _((const void *, const void *));
 
 static I32 sortcxix;
 
@@ -46,10 +50,14 @@ PP(pp_wantarray)
     if (cxix < 0)
 	RETPUSHUNDEF;
 
-    if (cxstack[cxix].blk_gimme == G_ARRAY)
+    switch (cxstack[cxix].blk_gimme) {
+    case G_ARRAY:
 	RETPUSHYES;
-    else
+    case G_SCALAR:
 	RETPUSHNO;
+    default:
+	RETPUSHUNDEF;
+    }
 }
 
 PP(pp_regcmaybe)
@@ -108,10 +116,9 @@ PP(pp_substcont)
 	if (cx->sb_iters > cx->sb_maxiters)
 	    DIE("Substitution loop");
 
+	if (!cx->sb_rxtainted)
+	    cx->sb_rxtainted = SvTAINTED(TOPs);
 	sv_catsv(dstr, POPs);
-	if (rx->subbase)
-	    Safefree(rx->subbase);
-	rx->subbase = cx->sb_subbase;
 
 	/* Are we done */
 	if (cx->sb_once || !pregexec(rx, s, cx->sb_strend, orig,
@@ -120,6 +127,8 @@ PP(pp_substcont)
 	    SV *targ = cx->sb_targ;
 	    sv_catpvn(dstr, s, cx->sb_strend - s);
 
+	    TAINT_IF(cx->sb_rxtainted || rx->exec_tainted);
+
 	    (void)SvOOK_off(targ);
 	    Safefree(SvPVX(targ));
 	    SvPVX(targ) = SvPVX(dstr);
@@ -127,9 +136,10 @@ PP(pp_substcont)
 	    SvLEN_set(targ, SvLEN(dstr));
 	    SvPVX(dstr) = 0;
 	    sv_free(dstr);
-
 	    (void)SvPOK_only(targ);
 	    SvSETMAGIC(targ);
+	    SvTAINT(targ);
+
 	    PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 	    LEAVE_SCOPE(cx->sb_oldsave);
 	    POPSUBST(cx);
@@ -146,9 +156,7 @@ PP(pp_substcont)
     cx->sb_m = m = rx->startp[0];
     sv_catpvn(dstr, s, m-s);
     cx->sb_s = rx->endp[0];
-    cx->sb_subbase = rx->subbase;
-
-    rx->subbase = Nullch;	/* so recursion works */
+    cx->sb_rxtainted |= rx->exec_tainted;
     RETURNOP(pm->op_pmreplstart);
 }
 
@@ -174,7 +182,7 @@ PP(pp_formline)
     bool gotsome;
     STRLEN len;
 
-    if (!SvCOMPILED(form)) {
+    if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
 	SvREADONLY_off(form);
 	doparseform(form);
     }
@@ -212,9 +220,9 @@ PP(pp_formline)
 	    case FF_END:	name = "END";		break;
 	    }
 	    if (arg >= 0)
-		fprintf(stderr, "%-16s%ld\n", name, (long) arg);
+		PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
 	    else
-		fprintf(stderr, "%-16s\n", name);
+		PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
 	} )
 	switch (*fpc++) {
 	case FF_LINEMARK:
@@ -376,6 +384,8 @@ PP(pp_formline)
 	    }
 	    gotsome = TRUE;
 	    value = SvNV(sv);
+	    /* Formats aren't yet marked for locales, so assume "yes". */
+	    SET_NUMERIC_LOCAL();
 	    if (arg & 256) {
 		sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
 	    } else {
@@ -450,7 +460,7 @@ PP(pp_grepstart)
 
     if (stack_base + *markstack_ptr == sp) {
 	(void)POPMARK;
-	if (GIMME != G_ARRAY)
+	if (GIMME_V == G_SCALAR)
 	    XPUSHs(&sv_no);
 	RETURNOP(op->op_next->op_next);
     }
@@ -513,6 +523,7 @@ PP(pp_mapwhile)
     /* All done yet? */
     if (markstack_ptr[-1] > *markstack_ptr) {
 	I32 items;
+	I32 gimme = GIMME_V;
 
 	(void)POPMARK;				/* pop top */
 	LEAVE;					/* exit outer scope */
@@ -520,12 +531,12 @@ PP(pp_mapwhile)
 	items = --*markstack_ptr - markstack_ptr[-1];
 	(void)POPMARK;				/* pop dst */
 	SP = stack_base + POPMARK;		/* pop original mark */
-	if (GIMME != G_ARRAY) {
+	if (gimme == G_SCALAR) {
 	    dTARGET;
 	    XPUSHi(items);
-	    RETURN;
 	}
-	SP += items;
+	else if (gimme == G_ARRAY)
+	    SP += items;
 	RETURN;
     }
     else {
@@ -574,7 +585,7 @@ PP(pp_sort)
 	    if (!(cv && CvROOT(cv))) {
 		if (gv) {
 		    SV *tmpstr = sv_newmortal();
-		    gv_efullname(tmpstr, gv);
+		    gv_efullname3(tmpstr, gv, Nullch);
 		    if (cv && CvXSUB(cv))
 			DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
 		    DIE("Undefined sort subroutine \"%s\" called",
@@ -604,10 +615,9 @@ PP(pp_sort)
     while (MARK < SP) {	/* This may or may not shift down one here. */
 	/*SUPPRESS 560*/
 	if (*up = *++MARK) {			/* Weed out nulls. */
-	    if (!SvPOK(*up))
+	    SvTEMP_off(*up);
+	    if (!sortcop && !SvPOK(*up))
 		(void)sv_2pv(*up, &na);
-	    else
-		SvTEMP_off(*up);
 	    up++;
 	}
     }
@@ -617,17 +627,19 @@ PP(pp_sort)
 	    AV *oldstack;
 	    CONTEXT *cx;
 	    SV** newsp;
+	    bool oldcatch = CATCH_GET;
 
 	    SAVETMPS;
 	    SAVESPTR(op);
 
-	    oldstack = stack;
+	    oldstack = curstack;
 	    if (!sortstack) {
 		sortstack = newAV();
 		AvREAL_off(sortstack);
 		av_extend(sortstack, 32);
 	    }
-	    SWITCHSTACK(stack, sortstack);
+	    CATCH_SET(TRUE);
+	    SWITCHSTACK(curstack, sortstack);
 	    if (sortstash != stash) {
 		firstgv = gv_fetchpv("a", TRUE, SVt_PV);
 		secondgv = gv_fetchpv("b", TRUE, SVt_PV);
@@ -636,20 +648,22 @@ PP(pp_sort)
 
 	    SAVESPTR(GvSV(firstgv));
 	    SAVESPTR(GvSV(secondgv));
-	    PUSHBLOCK(cx, CXt_LOOP, stack_base);
+	    PUSHBLOCK(cx, CXt_NULL, stack_base);
 	    sortcxix = cxstack_ix;
 
 	    qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
 
 	    POPBLOCK(cx,curpm);
 	    SWITCHSTACK(sortstack, oldstack);
+	    CATCH_SET(oldcatch);
 	}
 	LEAVE;
     }
     else {
 	if (max > 1) {
 	    MEXTEND(SP, 20);	/* Can't afford stack realloc on signal. */
-	    qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
+	    qsort((char*)(ORIGMARK+1), max, sizeof(SV*),
+		  (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp);
 	}
     }
     stack_sp = ORIGMARK + max;
@@ -707,14 +721,16 @@ PP(pp_flop)
 	I32 max;
 
 	if (SvNIOKp(left) || !SvPOKp(left) ||
-	  (looks_like_number(left) && *SvPVX(left) != '0') ) {
+	  (looks_like_number(left) && *SvPVX(left) != '0') )
+	{
 	    i = SvIV(left);
 	    max = SvIV(right);
-	    if (max > i)
+	    if (max >= i) {
+		EXTEND_MORTAL(max - i + 1);
 		EXTEND(SP, max - i + 1);
+	    }
 	    while (i <= max) {
-		sv = sv_mortalcopy(&sv_no);
-		sv_setiv(sv,i++);
+		sv = sv_2mortal(newSViv(i++));
 		PUSHs(sv);
 	    }
 	}
@@ -774,14 +790,18 @@ char *label;
 	    if (dowarn)
 		warn("Exiting eval via %s", op_name[op->op_type]);
 	    break;
+	case CXt_NULL:
+	    if (dowarn)
+		warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+	    return -1;
 	case CXt_LOOP:
 	    if (!cx->blk_loop.label ||
 	      strNE(label, cx->blk_loop.label) ) {
-		DEBUG_l(deb("(Skipping label #%d %s)\n",
-			i, cx->blk_loop.label));
+		DEBUG_l(deb("(Skipping label #%ld %s)\n",
+			(long)i, cx->blk_loop.label));
 		continue;
 	    }
-	    DEBUG_l( deb("(Found label #%d %s)\n", i, label));
+	    DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
 	    return i;
 	}
     }
@@ -791,16 +811,29 @@ char *label;
 I32
 dowantarray()
 {
+    I32 gimme = block_gimme();
+    return (gimme == G_VOID) ? G_SCALAR : gimme;
+}
+
+I32
+block_gimme()
+{
     I32 cxix;
 
     cxix = dopoptosub(cxstack_ix);
     if (cxix < 0)
 	return G_SCALAR;
 
-    if (cxstack[cxix].blk_gimme == G_ARRAY)
-	return G_ARRAY;
-    else
+    switch (cxstack[cxix].blk_gimme) {
+    case G_VOID:
+	return G_VOID;
+    case G_SCALAR:
 	return G_SCALAR;
+    case G_ARRAY:
+	return G_ARRAY;
+    default:
+	croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
+    }
 }
 
 static I32
@@ -816,7 +849,7 @@ I32 startingblock;
 	    continue;
 	case CXt_EVAL:
 	case CXt_SUB:
-	    DEBUG_l( deb("(Found sub #%d)\n", i));
+	    DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -835,7 +868,7 @@ I32 startingblock;
 	default:
 	    continue;
 	case CXt_EVAL:
-	    DEBUG_l( deb("(Found eval #%d)\n", i));
+	    DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -853,7 +886,7 @@ I32 startingblock;
 	switch (cx->cx_type) {
 	case CXt_SUBST:
 	    if (dowarn)
-		warn("Exiting substitition via %s", op_name[op->op_type]);
+		warn("Exiting substitution via %s", op_name[op->op_type]);
 	    break;
 	case CXt_SUB:
 	    if (dowarn)
@@ -863,8 +896,12 @@ I32 startingblock;
 	    if (dowarn)
 		warn("Exiting eval via %s", op_name[op->op_type]);
 	    break;
+	case CXt_NULL:
+	    if (dowarn)
+		warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+	    return -1;
 	case CXt_LOOP:
-	    DEBUG_l( deb("(Found loop #%d)\n", i));
+	    DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -881,7 +918,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(PerlIO_printf(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) {
@@ -894,53 +931,13 @@ I32 cxix;
 	case CXt_LOOP:
 	    POPLOOP(cx);
 	    break;
+	case CXt_NULL:
 	case CXt_SUBST:
 	    break;
 	}
     }
 }
 
-#ifdef I_STDARG
-OP *
-die(char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
-    char *pat;
-    va_dcl
-#endif
-{
-    va_list args;
-    char *message;
-    int oldrunlevel = runlevel;
-    int was_in_eval = in_eval;
-    HV *stash;
-    GV *gv;
-    CV *cv;
-
-#ifdef I_STDARG
-    va_start(args, pat);
-#else
-    va_start(args);
-#endif
-    message = mess(pat, &args);
-    va_end(args);
-    if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
-	dSP;
-
-	PUSHMARK(sp);
-	EXTEND(sp, 1);
-	PUSHs(sv_2mortal(newSVpv(message,0)));
-	PUTBACK;
-	perl_call_sv((SV*)cv, G_DISCARD);
-    }
-    restartop = die_where(message);
-    if ((!restartop && was_in_eval) || oldrunlevel > 1)
-	Siglongjmp(top_env, 3);
-    return restartop;
-}
-
 OP *
 die_where(message)
 char *message;
@@ -980,7 +977,7 @@ char *message;
 
 	    POPBLOCK(cx,curpm);
 	    if (cx->cx_type != CXt_EVAL) {
-		fprintf(stderr, "panic: die %s", message);
+		PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
 		my_exit(1);
 	    }
 	    POPEVAL(cx);
@@ -991,24 +988,17 @@ char *message;
 
 	    LEAVE;
 
-	    if (optype == OP_REQUIRE)
-		DIE("%s", SvPVx(GvSV(errgv), na));
+	    if (optype == OP_REQUIRE) {
+		char* msg = SvPVx(GvSV(errgv), na);
+		DIE("%s", *msg ? msg : "Compilation failed in require");
+	    }
 	    return pop_return();
 	}
     }
-    fputs(message, stderr);
-    (void)Fflush(stderr);
-    if (e_fp) {
-	fclose(e_fp);
-	e_fp = Nullfp;
-	(void)UNLINK(e_tmpname);
-    }
-    statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
-    my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
-#else
-    my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+    PerlIO_printf(PerlIO_stderr(), "%s",message);
+    PerlIO_flush(PerlIO_stderr());
+    my_failure_exit();
+    /* NOTREACHED */
     return 0;
 }
 
@@ -1060,6 +1050,7 @@ PP(pp_caller)
     register I32 cxix = dopoptosub(cxstack_ix);
     register CONTEXT *cx;
     I32 dbcxix;
+    I32 gimme;
     SV *sv;
     I32 count = 0;
 
@@ -1103,7 +1094,7 @@ PP(pp_caller)
 	RETURN;
     if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
 	sv = NEWSV(49, 0);
-	gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv));
+	gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
 	PUSHs(sv_2mortal(sv));
 	PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
     }
@@ -1111,7 +1102,11 @@ PP(pp_caller)
 	PUSHs(sv_2mortal(newSVpv("(eval)",0)));
 	PUSHs(sv_2mortal(newSViv(0)));
     }
-    PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
+    gimme = (I32)cx->blk_gimme;
+    if (gimme == G_VOID)
+	PUSHs(&sv_undef);
+    else
+	PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
     if (cx->cx_type == CXt_EVAL) {
 	if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
 	    PUSHs(cx->blk_eval.cur_text);
@@ -1151,8 +1146,8 @@ sortcv(a, b)
 const void *a;
 const void *b;
 {
-    SV **str1 = (SV **) a;
-    SV **str2 = (SV **) b;
+    SV * const *str1 = (SV * const *)a;
+    SV * const *str2 = (SV * const *)b;
     I32 oldsaveix = savestack_ix;
     I32 oldscopeix = scopestack_ix;
     I32 result;
@@ -1160,7 +1155,7 @@ const void *b;
     GvSV(secondgv) = *str2;
     stack_sp = stack_base;
     op = sortcop;
-    run();
+    runops();
     if (stack_sp != stack_base + 1)
 	croak("Sort subroutine didn't return single value");
     if (!SvNIOKp(*stack_sp))
@@ -1178,33 +1173,15 @@ sortcmp(a, b)
 const void *a;
 const void *b;
 {
-    register SV *str1 = *(SV **) a;
-    register SV *str2 = *(SV **) b;
-    I32 retval;
-
-    if (!SvPOKp(str1)) {
-	if (!SvPOKp(str2))
-	    return 0;
-	else
-	    return -1;
-    }
-    if (!SvPOKp(str2))
-	return 1;
+    return sv_cmp(*(SV * const *)a, *(SV * const *)b);
+}
 
-    if (SvCUR(str1) < SvCUR(str2)) {
-	/*SUPPRESS 560*/
-	if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
-	    return retval;
-	else
-	    return -1;
-    }
-    /*SUPPRESS 560*/
-    else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
-	return retval;
-    else if (SvCUR(str1) == SvCUR(str2))
-	return 0;
-    else
-	return 1;
+static int
+sortcmp_locale(a, b)
+const void *a;
+const void *b;
+{
+    return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b);
 }
 
 PP(pp_reset)
@@ -1254,7 +1231,7 @@ PP(pp_dbstate)
 	SAVETMPS;
 
 	SAVEI32(debug);
-	SAVESPTR(stack_sp);
+	SAVESTACK_POS();
 	debug = 0;
 	hasargs = 0;
 	sp = stack_sp;
@@ -1281,7 +1258,7 @@ PP(pp_enteriter)
 {
     dSP; dMARK;
     register CONTEXT *cx;
-    I32 gimme = GIMME;
+    I32 gimme = GIMME_V;
     SV **svp;
 
     ENTER;
@@ -1298,14 +1275,11 @@ PP(pp_enteriter)
 
     PUSHBLOCK(cx, CXt_LOOP, SP);
     PUSHLOOP(cx, svp, MARK);
-    if (op->op_flags & OPf_STACKED) {
-	AV* av = (AV*)POPs;
-	cx->blk_loop.iterary = av;
-	cx->blk_loop.iterix = -1;
-    }
+    if (op->op_flags & OPf_STACKED)
+	cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
     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;
     }
 
@@ -1316,7 +1290,7 @@ PP(pp_enterloop)
 {
     dSP;
     register CONTEXT *cx;
-    I32 gimme = GIMME;
+    I32 gimme = GIMME_V;
 
     ENTER;
     SAVETMPS;
@@ -1332,6 +1306,7 @@ PP(pp_leaveloop)
 {
     dSP;
     register CONTEXT *cx;
+    struct block_loop cxloop;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -1339,27 +1314,30 @@ PP(pp_leaveloop)
 
     POPBLOCK(cx,newpm);
     mark = newsp;
-    POPLOOP(cx);
-    if (gimme == G_SCALAR) {
-	if (op->op_private & OPpLEAVE_VOID)
-	    ;
-	else {
-	    if (mark < SP)
-		*++newsp = sv_mortalcopy(*SP);
-	    else
-		*++newsp = &sv_undef;
-	}
+    POPLOOP1(cx);	/* Delay POPLOOP2 until stack values are safe */
+
+    if (gimme == G_VOID)
+	; /* do nothing */
+    else if (gimme == G_SCALAR) {
+	if (mark < SP)
+	    *++newsp = sv_mortalcopy(*SP);
+	else
+	    *++newsp = &sv_undef;
     }
     else {
 	while (mark < SP)
 	    *++newsp = sv_mortalcopy(*++mark);
     }
-    curpm = newpm;	/* Don't pop $1 et al till now */
-    sp = newsp;
+    SP = newsp;
+    PUTBACK;
+
+    POPLOOP2();		/* Stack values are safe: release loop vars ... */
+    curpm = newpm;	/* ... and pop $1 et al */
+
     LEAVE;
     LEAVE;
 
-    RETURN;
+    return NORMAL;
 }
 
 PP(pp_return)
@@ -1367,16 +1345,18 @@ PP(pp_return)
     dSP; dMARK;
     I32 cxix;
     register CONTEXT *cx;
+    struct block_sub cxsub;
+    bool popsub2 = FALSE;
     I32 gimme;
     SV **newsp;
     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;
 	}
@@ -1391,13 +1371,15 @@ PP(pp_return)
     POPBLOCK(cx,newpm);
     switch (cx->cx_type) {
     case CXt_SUB:
-	POPSUB(cx);
+	POPSUB1(cx);	/* Delay POPSUB2 until stack values are safe */
+	popsub2 = TRUE;
 	break;
     case CXt_EVAL:
 	POPEVAL(cx);
 	if (optype == OP_REQUIRE &&
 	    (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
 	{
+	    /* Unassume the success we assumed earlier. */
 	    char *name = cx->blk_eval.old_name;
 	    (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
 	    DIE("%s did not return a true value", name);
@@ -1405,22 +1387,28 @@ PP(pp_return)
 	break;
     default:
 	DIE("panic: return");
-	break;
     }
 
     if (gimme == G_SCALAR) {
 	if (MARK < SP)
-	    *++newsp = sv_mortalcopy(*SP);
+	    *++newsp = (popsub2 && SvTEMP(*SP))
+			? *SP : sv_mortalcopy(*SP);
 	else
 	    *++newsp = &sv_undef;
     }
-    else {
-	while (MARK < SP)
-	    *++newsp = sv_mortalcopy(*++MARK);
+    else if (gimme == G_ARRAY) {
+	while (++MARK <= SP)
+	    *++newsp = (popsub2 && SvTEMP(*MARK))
+			? *MARK : sv_mortalcopy(*MARK);
     }
-    curpm = newpm;	/* Don't pop $1 et al till now */
     stack_sp = newsp;
 
+    /* Stack values are safe: */
+    if (popsub2) {
+	POPSUB2();	/* release CV and @_ ... */
+    }
+    curpm = newpm;	/* ... and pop $1 et al */
+
     LEAVE;
     return pop_return();
 }
@@ -1430,6 +1418,9 @@ PP(pp_last)
     dSP;
     I32 cxix;
     register CONTEXT *cx;
+    struct block_loop cxloop;
+    struct block_sub cxsub;
+    I32 pop2 = 0;
     I32 gimme;
     I32 optype;
     OP *nextop;
@@ -1453,38 +1444,52 @@ PP(pp_last)
     POPBLOCK(cx,newpm);
     switch (cx->cx_type) {
     case CXt_LOOP:
-	POPLOOP(cx);
-	nextop = cx->blk_loop.last_op->op_next;
-	LEAVE;
+	POPLOOP1(cx);	/* Delay POPLOOP2 until stack values are safe */
+	pop2 = CXt_LOOP;
+	nextop = cxloop.last_op->op_next;
 	break;
-    case CXt_EVAL:
-	POPEVAL(cx);
+    case CXt_SUB:
+	POPSUB1(cx);	/* Delay POPSUB2 until stack values are safe */
+	pop2 = CXt_SUB;
 	nextop = pop_return();
 	break;
-    case CXt_SUB:
-	POPSUB(cx);
+    case CXt_EVAL:
+	POPEVAL(cx);
 	nextop = pop_return();
 	break;
     default:
 	DIE("panic: last");
-	break;
     }
 
     if (gimme == G_SCALAR) {
-	if (mark < SP)
-	    *++newsp = sv_mortalcopy(*SP);
+	if (MARK < SP)
+	    *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
+			? *SP : sv_mortalcopy(*SP);
 	else
 	    *++newsp = &sv_undef;
     }
-    else {
-	while (mark < SP)
-	    *++newsp = sv_mortalcopy(*++mark);
+    else if (gimme == G_ARRAY) {
+	while (++MARK <= SP)
+	    *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
+			? *MARK : sv_mortalcopy(*MARK);
     }
-    curpm = newpm;	/* Don't pop $1 et al till now */
-    sp = newsp;
+    SP = newsp;
+    PUTBACK;
+
+    /* Stack values are safe: */
+    switch (pop2) {
+    case CXt_LOOP:
+	POPLOOP2();	/* release loop vars ... */
+	LEAVE;
+	break;
+    case CXt_SUB:
+	POPSUB2();	/* release CV and @_ ... */
+	break;
+    }
+    curpm = newpm;	/* ... and pop $1 et al */
 
     LEAVE;
-    RETURNOP(nextop);
+    return nextop;
 }
 
 PP(pp_next)
@@ -1612,7 +1617,7 @@ PP(pp_goto)
 	    if (!CvROOT(cv) && !CvXSUB(cv)) {
 		if (CvGV(cv)) {
 		    SV *tmpstr = sv_newmortal();
-		    gv_efullname(tmpstr, CvGV(cv));
+		    gv_efullname3(tmpstr, CvGV(cv), Nullch);
 		    DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
 		}
 		DIE("Goto undefined subroutine");
@@ -1630,8 +1635,11 @@ 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;
+		SvREFCNT_dec(GvAV(defgv));
 		GvAV(defgv) = cx->blk_sub.savearray;
 		AvREAL_off(av);
 		av_clear(av);
@@ -1657,6 +1665,7 @@ PP(pp_goto)
 		    sp = stack_base + items;
 		}
 		else {
+		    stack_sp--;		/* There is no cv arg. */
 		    (void)(*CvXSUB(cv))(cv);
 		}
 		LEAVE;
@@ -1672,8 +1681,7 @@ PP(pp_goto)
 		    (void)SvREFCNT_inc(cv);
 		else {	/* save temporaries on recursion? */
 		    if (CvDEPTH(cv) == 100 && dowarn)
-			warn("Deep recursion on subroutine \"%s\"",
-			    GvENAME(CvGV(cv)));
+			sub_crush_depth(cv);
 		    if (CvDEPTH(cv) > AvFILL(padlist)) {
 			AV *newpad = newAV();
 			SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
@@ -1682,8 +1690,10 @@ PP(pp_goto)
 			for ( ;ix > 0; ix--) {
 			    if (svp[ix] != &sv_undef) {
 				char *name = SvPVX(svp[ix]);
-				if (SvFLAGS(svp[ix]) & SVf_FAKE) {
-				    /* outer lexical? */
+				if ((SvFLAGS(svp[ix]) & SVf_FAKE)
+				    || *name == '&')
+				{
+				    /* outer lexical or anon code */
 				    av_store(newpad, ix,
 					SvREFCNT_inc(oldpad[ix]) );
 				}
@@ -1721,7 +1731,7 @@ PP(pp_goto)
 
 		    cx->blk_sub.savearray = GvAV(defgv);
 		    cx->blk_sub.argarray = av;
-		    GvAV(defgv) = cx->blk_sub.argarray;
+		    GvAV(defgv) = (AV*)SvREFCNT_inc(av);
 		    ++mark;
 
 		    if (items >= AvMAX(av) + 1) {
@@ -1746,6 +1756,15 @@ PP(pp_goto)
 			mark++;
 		    }
 		}
+		if (perldb && curstash != debstash) {
+		    /*
+		     * We do not care about using sv to call CV;
+		     * it's for informational purposes only.
+		     */
+		    SV *sv = GvSV(DBsub);
+		    save_item(sv);
+		    gv_efullname3(sv, CvGV(cv), Nullch);
+		}
 		RETURNOP(CvSTART(cv));
 	    }
 	}
@@ -1786,11 +1805,12 @@ PP(pp_goto)
 		else
 		    gotoprobe = main_root;
 		break;
+	    case CXt_NULL:
+		DIE("Can't \"goto\" outside a block");
 	    default:
 		if (ix)
 		    DIE("panic: goto");
-		else
-		    gotoprobe = main_root;
+		gotoprobe = main_root;
 		break;
 	    }
 	    retop = dofindlabel(gotoprobe, label, enterops);
@@ -1839,9 +1859,9 @@ PP(pp_goto)
 	do_undump = FALSE;
     }
 
-    if (stack == signalstack) {
+    if (curstack == signalstack) {
         restartop = retop;
-        Siglongjmp(top_env, 3);
+        JMPENV_JUMP(3);
     }
 
     RETURNOP(retop);
@@ -1854,8 +1874,13 @@ PP(pp_exit)
 
     if (MAXARG < 1)
 	anum = 0;
-    else
+    else {
 	anum = SvIVx(POPs);
+#ifdef VMSISH_EXIT
+	if (anum == 1 && VMSISH_EXIT)
+	    anum = 0;
+#endif
+    }
     my_exit(anum);
     PUSHs(&sv_undef);
     RETURN;
@@ -1930,29 +1955,74 @@ SV *sv;
 }
 
 static OP *
+docatch(o)
+OP *o;
+{
+    int ret;
+    I32 oldrunlevel = runlevel;
+    OP *oldop = op;
+    dJMPENV;
+
+    op = o;
+#ifdef DEBUGGING
+    assert(CATCH_GET == TRUE);
+    DEBUG_l(deb("(Setting up local jumplevel, runlevel = %ld)\n", (long)runlevel+1));
+#endif
+    JMPENV_PUSH(ret);
+    switch (ret) {
+    default:				/* topmost level handles it */
+	JMPENV_POP;
+	runlevel = oldrunlevel;
+	op = oldop;
+	JMPENV_JUMP(ret);
+	/* NOTREACHED */
+    case 3:
+	if (!restartop) {
+	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+	    break;
+	}
+	op = restartop;
+	restartop = 0;
+	/* FALL THROUGH */
+    case 0:
+        runops();
+	break;
+    }
+    JMPENV_POP;
+    runlevel = oldrunlevel;
+    op = oldop;
+    return Nullop;
+}
+
+static OP *
 doeval(gimme)
 int gimme;
 {
     dSP;
     OP *saveop = op;
     HV *newstash;
+    CV *caller;
     AV* comppadlist;
 
     in_eval = 1;
 
+    PUSHMARK(SP);
+
     /* set up a scratch pad */
 
-    SAVEINT(padix);
+    SAVEI32(padix);
     SAVESPTR(curpad);
     SAVESPTR(comppad);
     SAVESPTR(comppad_name);
-    SAVEINT(comppad_name_fill);
-    SAVEINT(min_intro_pending);
-    SAVEINT(max_intro_pending);
+    SAVEI32(comppad_name_fill);
+    SAVEI32(min_intro_pending);
+    SAVEI32(max_intro_pending);
 
+    caller = compcv;
     SAVESPTR(compcv);
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
+    CvUNIQUE_on(compcv);
 
     comppad = newAV();
     comppad_name = newAV();
@@ -1967,6 +2037,10 @@ int gimme;
     av_store(comppadlist, 0, (SV*)comppad_name);
     av_store(comppadlist, 1, (SV*)comppad);
     CvPADLIST(compcv) = comppadlist;
+
+    if (saveop->op_type != OP_REQUIRE)
+	CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+
     SAVEFREESV(compcv);
 
     /* make sure we compile in the right package */
@@ -1988,7 +2062,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;
@@ -2000,13 +2077,16 @@ int gimme;
 	    op_free(eval_root);
 	    eval_root = Nullop;
 	}
+	SP = stack_base + POPMARK;		/* pop original mark */
 	POPBLOCK(cx,curpm);
 	POPEVAL(cx);
 	pop_return();
 	lex_end();
 	LEAVE;
-	if (optype == OP_REQUIRE)
-	    DIE("%s", SvPVx(GvSV(errgv), na));
+	if (optype == OP_REQUIRE) {
+	    char* msg = SvPVx(GvSV(errgv), na);
+	    DIE("%s", *msg ? msg : "Compilation failed in require");
+	}
 	SvREFCNT_dec(rs);
 	rs = SvREFCNT_inc(nrs);
 	RETPUSHUNDEF;
@@ -2015,15 +2095,32 @@ int gimme;
     rs = SvREFCNT_inc(nrs);
     compiling.cop_line = 0;
     SAVEFREEOP(eval_root);
-    if (gimme & G_ARRAY)
+    if (gimme & G_VOID)
+	scalarvoid(eval_root);
+    else if (gimme & G_ARRAY)
 	list(eval_root);
     else
 	scalar(eval_root);
 
     DEBUG_x(dump_eval());
 
+    /* Register with debugger: */
+    if (perldb && saveop->op_type == OP_REQUIRE) {
+	CV *cv = perl_get_cv("DB::postponed", FALSE);
+	if (cv) {
+	    dSP;
+	    PUSHMARK(sp);
+	    XPUSHs((SV*)compiling.cop_filegv);
+	    PUTBACK;
+	    perl_call_sv((SV*)cv, G_DISCARD);
+	}
+    }
+
     /* compiled okay, so do it */
 
+    CvDEPTH(compcv) = 1;
+
+    SP = stack_base + POPMARK;		/* pop original mark */
     RETURNOP(eval_start);
 }
 
@@ -2036,10 +2133,11 @@ PP(pp_require)
     char *tmpname;
     SV** svp;
     I32 gimme = G_SCALAR;
-    FILE *tryrsfp = 0;
+    PerlIO *tryrsfp = 0;
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
+	SET_NUMERIC_STANDARD();
 	if (atof(patchlevel) + 0.00000999 < SvNV(sv))
 	    DIE("Perl %s required--this is only version %s, stopped",
 		SvPV(sv,na),patchlevel);
@@ -2065,27 +2163,29 @@ PP(pp_require)
       || (tmpname[0] && tmpname[1] == ':')
 #endif
 #ifdef VMS
-	|| (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
-	    (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')))
+	|| (strchr(tmpname,':')  || ((*tmpname == '[' || *tmpname == '<') &&
+	    (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1]))))
 #endif
     )
     {
-	tryrsfp = fopen(tmpname,"r");
+	tryrsfp = PerlIO_open(tmpname,"r");
     }
     else {
 	AV *ar = GvAVn(incgv);
 	I32 i;
-
-	for (i = 0; i <= AvFILL(ar); i++) {
 #ifdef VMS
+	char unixified[256];
+	if (tounixspec_ts(tmpname,unixified) != NULL)
+	  for (i = 0; i <= AvFILL(ar); i++) {
 	    if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
 		continue;
-	    strcat(buf,name);
+	    strcat(buf,unixified);
 #else
+	for (i = 0; i <= AvFILL(ar); i++) {
 	    (void)sprintf(buf, "%s/%s",
 		SvPVx(*av_fetch(ar, i, TRUE), na), name);
 #endif
-	    tryrsfp = fopen(buf, "r");
+	    tryrsfp = PerlIO_open(buf, "r");
 	    if (tryrsfp) {
 		char *s = buf;
 
@@ -2141,7 +2241,7 @@ PP(pp_require)
     compiling.cop_line = 0;
 
     PUTBACK;
-    return doeval(G_SCALAR);
+    return DOCATCH(doeval(G_SCALAR));
 }
 
 PP(pp_dofile)
@@ -2154,9 +2254,10 @@ PP(pp_entereval)
     dSP;
     register CONTEXT *cx;
     dPOPss;
-    I32 gimme = GIMME;
-    char tmpbuf[32];
+    I32 gimme = GIMME_V, was = sub_generation;
+    char tmpbuf[32], *safestr;
     STRLEN len;
+    OP *ret;
 
     if (!SvPV(sv,len) || !len)
 	RETPUSHUNDEF;
@@ -2169,10 +2270,16 @@ PP(pp_entereval)
     /* switch to eval mode */
 
     SAVESPTR(compiling.cop_filegv);
-    sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
+    sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
     compiling.cop_line = 1;
-    SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf));
+    /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+       deleting the eval's FILEGV from the stash before gv_check() runs
+       (i.e. before run-time proper). To work around the coredump that
+       ensues, we always turn GvMULTI_on for any globals that were
+       introduced within evals. See force_ident(). GSAR 96-10-12 */
+    safestr = savepv(tmpbuf);
+    SAVEDELETE(defstash, safestr, strlen(safestr));
     SAVEI32(hints);
     hints = op->op_targ;
 
@@ -2185,7 +2292,11 @@ PP(pp_entereval)
     if (perldb && curstash != debstash)
 	save_lines(GvAV(compiling.cop_filegv), linestr);
     PUTBACK;
-    return doeval(gimme);
+    ret = doeval(gimme);
+    if (perldb && was != sub_generation) { /* Some subs defined here. */
+	strcpy(safestr, "_<(eval )");	/* Anything fake and short. */
+    }
+    return DOCATCH(ret);
 }
 
 PP(pp_leaveeval)
@@ -2197,53 +2308,55 @@ PP(pp_leaveeval)
     I32 gimme;
     register CONTEXT *cx;
     OP *retop;
+    U8 save_flags = op -> op_flags;
     I32 optype;
 
     POPBLOCK(cx,newpm);
     POPEVAL(cx);
     retop = pop_return();
 
-    if (gimme == G_SCALAR) {
-	if (op->op_private & OPpLEAVE_VOID)
-	    MARK = newsp;
+    if (gimme == G_VOID)
+	MARK = newsp;
+    else if (gimme == G_SCALAR) {
+	MARK = newsp + 1;
+	if (MARK <= SP) {
+	    if (SvFLAGS(TOPs) & SVs_TEMP)
+		*MARK = TOPs;
+	    else
+		*MARK = sv_mortalcopy(TOPs);
+	}
 	else {
-	    MARK = newsp + 1;
-	    if (MARK <= SP) {
-		if (SvFLAGS(TOPs) & SVs_TEMP)
-		    *MARK = TOPs;
-		else
-		    *MARK = sv_mortalcopy(TOPs);
-	    }
-	    else {
-		MEXTEND(mark,0);
-		*MARK = &sv_undef;
-	    }
+	    MEXTEND(mark,0);
+	    *MARK = &sv_undef;
 	}
-	SP = MARK;
     }
     else {
 	for (mark = newsp + 1; mark <= SP; mark++)
-	    if (!(SvFLAGS(TOPs) & SVs_TEMP))
+	    if (!(SvFLAGS(*mark) & SVs_TEMP))
 		*mark = sv_mortalcopy(*mark);
 		/* in case LEAVE wipes old return values */
     }
     curpm = newpm;	/* Don't pop $1 et al till now */
 
-    if (optype != OP_ENTEREVAL) {
-	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);
+#ifdef DEBUGGING
+    assert(CvDEPTH(compcv) == 1);
+#endif
+    CvDEPTH(compcv) = 0;
 
-	    if (optype == OP_REQUIRE)
-		retop = die("%s did not return a true value", name);
-	}
+    if (optype == OP_REQUIRE &&
+	!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp))
+    {
+	/* Unassume the success we assumed earlier. */
+	char *name = cx->blk_eval.old_name;
+	(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 (!(save_flags & OPf_SPECIAL))
+	sv_setpv(GvSV(errgv),"");
 
     RETURNOP(retop);
 }
@@ -2252,7 +2365,7 @@ PP(pp_entertry)
 {
     dSP;
     register CONTEXT *cx;
-    I32 gimme = GIMME;
+    I32 gimme = GIMME_V;
 
     ENTER;
     SAVETMPS;
@@ -2264,7 +2377,8 @@ PP(pp_entertry)
 
     in_eval = 1;
     sv_setpv(GvSV(errgv),"");
-    RETURN;
+    PUTBACK;
+    return DOCATCH(op->op_next);
 }
 
 PP(pp_leavetry)
@@ -2281,27 +2395,25 @@ PP(pp_leavetry)
     POPEVAL(cx);
     pop_return();
 
-    if (gimme == G_SCALAR) {
-	if (op->op_private & OPpLEAVE_VOID)
-	    MARK = newsp;
+    if (gimme == G_VOID)
+	SP = newsp;
+    else if (gimme == G_SCALAR) {
+	MARK = newsp + 1;
+	if (MARK <= SP) {
+	    if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
+		*MARK = TOPs;
+	    else
+		*MARK = sv_mortalcopy(TOPs);
+	}
 	else {
-	    MARK = newsp + 1;
-	    if (MARK <= SP) {
-		if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
-		    *MARK = TOPs;
-		else
-		    *MARK = sv_mortalcopy(TOPs);
-	    }
-	    else {
-		MEXTEND(mark,0);
-		*MARK = &sv_undef;
-	    }
+	    MEXTEND(mark,0);
+	    *MARK = &sv_undef;
 	}
 	SP = MARK;
     }
     else {
 	for (mark = newsp + 1; mark <= SP; mark++)
-	    if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
+	    if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
 		*mark = sv_mortalcopy(*mark);
 		/* in case LEAVE wipes old return values */
     }
@@ -2330,7 +2442,10 @@ SV *sv;
     register I32 arg;
     bool ischop;
 
-    New(804, fops, (send - s)*3+2, U16);    /* Almost certainly too long... */
+    if (len == 0)
+	croak("Null picture in formline");
+    
+    New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
     fpc = fops;
 
     if (s < send) {
@@ -2363,13 +2478,12 @@ SV *sv;
 	    skipspaces++;
 	    arg -= skipspaces;
 	    if (arg) {
-		if (postspace) {
+		if (postspace)
 		    *fpc++ = FF_SPACE;
-		    postspace = FALSE;
-		}
 		*fpc++ = FF_LITERAL;
 		*fpc++ = arg;
 	    }
+	    postspace = FALSE;
 	    if (s <= send)
 		skipspaces--;
 	    if (skipspaces) {
@@ -2485,5 +2599,6 @@ SV *sv;
     }
     Copy(fops, s, arg, U16);
     Safefree(fops);
+    sv_magic(sv, Nullsv, 'f', Nullch, 0);
     SvCOMPILED_on(sv);
 }