X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=0a01c11e7cd620136e19f13f08e276a7782640a7;hb=3c10ad8e31f7d77e71c048b1746912f41cb540f0;hp=29353cbfa2d0209f8c87806454825cb8007a31a7;hpb=06a5b7308953dd4bbb6c07edac1646b954045562;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 29353cb..0a01c11 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) (mustcatch ? 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;
 
@@ -102,12 +106,14 @@ PP(pp_substcont)
     register char *s = cx->sb_s;
     register char *m = cx->sb_m;
     char *orig = cx->sb_orig;
-    register REGEXP *rx = pm->op_pmregexp;
+    register REGEXP *rx = cx->sb_rx;
 
     if (cx->sb_iters++) {
 	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);
@@ -120,6 +126,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);
@@ -130,6 +138,7 @@ PP(pp_substcont)
 
 	    (void)SvPOK_only(targ);
 	    SvSETMAGIC(targ);
+	    SvTAINT(targ);
 	    PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 	    LEAVE_SCOPE(cx->sb_oldsave);
 	    POPSUBST(cx);
@@ -147,6 +156,7 @@ PP(pp_substcont)
     sv_catpvn(dstr, s, m-s);
     cx->sb_s = rx->endp[0];
     cx->sb_subbase = rx->subbase;
+    cx->sb_rxtainted |= rx->exec_tainted;
 
     rx->subbase = Nullch;	/* so recursion works */
     RETURNOP(pm->op_pmreplstart);
@@ -174,7 +184,7 @@ PP(pp_formline)
     bool gotsome;
     STRLEN len;
 
-    if (!SvCOMPILED(form)) {
+    if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
 	SvREADONLY_off(form);
 	doparseform(form);
     }
@@ -212,9 +222,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 +386,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 {
@@ -574,7 +586,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 +616,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 +628,19 @@ PP(pp_sort)
 	    AV *oldstack;
 	    CONTEXT *cx;
 	    SV** newsp;
+	    bool oldmustcatch = mustcatch;
 
 	    SAVETMPS;
 	    SAVESPTR(op);
 
-	    oldstack = stack;
+	    oldstack = curstack;
 	    if (!sortstack) {
 		sortstack = newAV();
 		AvREAL_off(sortstack);
 		av_extend(sortstack, 32);
 	    }
-	    SWITCHSTACK(stack, sortstack);
+	    mustcatch = TRUE;
+	    SWITCHSTACK(curstack, sortstack);
 	    if (sortstash != stash) {
 		firstgv = gv_fetchpv("a", TRUE, SVt_PV);
 		secondgv = gv_fetchpv("b", TRUE, SVt_PV);
@@ -636,20 +649,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);
+	    mustcatch = oldmustcatch;
 	}
 	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 +722,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 +791,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;
 	}
     }
@@ -816,7 +837,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 +856,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 +874,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 +884,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 +906,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 +919,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)
-	longjmp(top_env, 3);
-    return restartop;
-}
-
 OP *
 die_where(message)
 char *message;
@@ -969,7 +954,7 @@ char *message;
 	    }
 	}
 	else
-	    sv_catpv(GvSV(errgv), message);
+	    sv_setpv(GvSV(errgv), message);
 	
 	cxix = dopoptoeval(cxstack_ix);
 	if (cxix >= 0) {
@@ -980,7 +965,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);
@@ -996,16 +981,10 @@ char *message;
 	    return pop_return();
 	}
     }
-    fputs(message, stderr);
-    (void)fflush(stderr);
-    if (e_fp)
-	(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;
 }
 
@@ -1100,7 +1079,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)));
     }
@@ -1131,7 +1110,7 @@ PP(pp_caller)
 	    GV* tmpgv;
 	    dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
 				SVt_PVAV)));
-	    SvMULTI_on(tmpgv);
+	    GvMULTI_on(tmpgv);
 	    AvREAL_off(dbargs);		/* XXX Should be REIFY */
 	}
 
@@ -1148,8 +1127,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;
@@ -1157,7 +1136,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))
@@ -1175,33 +1154,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)
@@ -1251,7 +1212,7 @@ PP(pp_dbstate)
 	SAVETMPS;
 
 	SAVEI32(debug);
-	SAVESPTR(stack_sp);
+	SAVESTACK_POS();
 	debug = 0;
 	hasargs = 0;
 	sp = stack_sp;
@@ -1295,14 +1256,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;
     }
 
@@ -1329,6 +1287,7 @@ PP(pp_leaveloop)
 {
     dSP;
     register CONTEXT *cx;
+    struct block_loop cxloop;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -1336,7 +1295,8 @@ PP(pp_leaveloop)
 
     POPBLOCK(cx,newpm);
     mark = newsp;
-    POPLOOP(cx);
+    POPLOOP1(cx);	/* Delay POPLOOP2 until stack values are safe */
+
     if (gimme == G_SCALAR) {
 	if (op->op_private & OPpLEAVE_VOID)
 	    ;
@@ -1351,12 +1311,16 @@ PP(pp_leaveloop)
 	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)
@@ -1364,16 +1328,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;
 	}
@@ -1388,7 +1354,8 @@ 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);
@@ -1407,17 +1374,24 @@ PP(pp_return)
 
     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);
+	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();
 }
@@ -1427,6 +1401,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;
@@ -1450,16 +1427,17 @@ 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:
@@ -1468,20 +1446,34 @@ PP(pp_last)
     }
 
     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);
+	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)
@@ -1609,7 +1601,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");
@@ -1627,8 +1619,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);
@@ -1654,6 +1649,7 @@ PP(pp_goto)
 		    sp = stack_base + items;
 		}
 		else {
+		    stack_sp--;		/* There is no cv arg. */
 		    (void)(*CvXSUB(cv))(cv);
 		}
 		LEAVE;
@@ -1669,8 +1665,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]);
@@ -1679,8 +1674,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]) );
 				}
@@ -1718,7 +1715,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) {
@@ -1743,6 +1740,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));
 	    }
 	}
@@ -1783,6 +1789,9 @@ PP(pp_goto)
 		else
 		    gotoprobe = main_root;
 		break;
+	    case CXt_NULL:
+		DIE("Can't \"goto\" outside a block");
+		break;
 	    default:
 		if (ix)
 		    DIE("panic: goto");
@@ -1824,6 +1833,9 @@ PP(pp_goto)
     }
 
     if (do_dump) {
+#ifdef VMS
+	if (!retop) retop = main_start;
+#endif
 	restartop = retop;
 	do_undump = TRUE;
 
@@ -1833,9 +1845,9 @@ PP(pp_goto)
 	do_undump = FALSE;
     }
 
-    if (stack == signalstack) {
+    if (curstack == signalstack) {
         restartop = retop;
-        longjmp(top_env, 3);
+        Siglongjmp(top_env, 3);
     }
 
     RETURNOP(retop);
@@ -1848,8 +1860,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;
@@ -1924,29 +1941,77 @@ SV *sv;
 }
 
 static OP *
+docatch(o)
+OP *o;
+{
+    int ret;
+    int oldrunlevel = runlevel;
+    OP *oldop = op;
+    Sigjmp_buf oldtop;
+
+    op = o;
+    Copy(top_env, oldtop, 1, Sigjmp_buf);
+#ifdef DEBUGGING
+    assert(mustcatch == TRUE);
+#endif
+    mustcatch = FALSE;
+    switch ((ret = Sigsetjmp(top_env,1))) {
+    default:				/* topmost level handles it */
+	Copy(oldtop, top_env, 1, Sigjmp_buf);
+	runlevel = oldrunlevel;
+	mustcatch = TRUE;
+	op = oldop;
+	Siglongjmp(top_env, ret);
+	/* NOTREACHED */
+    case 3:
+	if (!restartop) {
+	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+	    break;
+	}
+	mustcatch = FALSE;
+	op = restartop;
+	restartop = 0;
+	/* FALL THROUGH */
+    case 0:
+        runops();
+	break;
+    }
+    Copy(oldtop, top_env, 1, Sigjmp_buf);
+    runlevel = oldrunlevel;
+    mustcatch = TRUE;
+    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();
@@ -1961,6 +2026,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 */
@@ -1980,11 +2049,12 @@ int gimme;
     error_count = 0;
     curcop = &compiling;
     curcop->cop_arybase = 0;
-    rs = "\n";
-    rslen = 1;
-    rschar = '\n';
-    rspara = 0;
-    sv_setpv(GvSV(errgv),"");
+    SvREFCNT_dec(rs);
+    rs = newSVpv("\n", 1);
+    if (saveop->op_flags & OPf_SPECIAL)
+	in_eval |= 4;
+    else
+	sv_setpv(GvSV(errgv),"");
     if (yyparse() || error_count || !eval_root) {
 	SV **newsp;
 	I32 gimme;
@@ -1996,6 +2066,7 @@ int gimme;
 	    op_free(eval_root);
 	    eval_root = Nullop;
 	}
+	SP = stack_base + POPMARK;		/* pop original mark */
 	POPBLOCK(cx,curpm);
 	POPEVAL(cx);
 	pop_return();
@@ -2003,16 +2074,12 @@ int gimme;
 	LEAVE;
 	if (optype == OP_REQUIRE)
 	    DIE("%s", SvPVx(GvSV(errgv), na));
-	rs = nrs;
-	rslen = nrslen;
-	rschar = nrschar;
-	rspara = (nrslen == 2);
+	SvREFCNT_dec(rs);
+	rs = SvREFCNT_inc(nrs);
 	RETPUSHUNDEF;
     }
-    rs = nrs;
-    rslen = nrslen;
-    rschar = nrschar;
-    rspara = (nrslen == 2);
+    SvREFCNT_dec(rs);
+    rs = SvREFCNT_inc(nrs);
     compiling.cop_line = 0;
     SAVEFREEOP(eval_root);
     if (gimme & G_ARRAY)
@@ -2022,8 +2089,23 @@ int gimme;
 
     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,13 +2118,14 @@ PP(pp_require)
     char *tmpname;
     SV** svp;
     I32 gimme = G_SCALAR;
-    FILE *tryrsfp = 0;
+    PerlIO *tryrsfp = 0;
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
-	if (atof(patchlevel) + 0.000999 < SvNV(sv))
-	    DIE("Perl %3.3f required--this is only version %s, stopped",
-		SvNV(sv),patchlevel);
+	SET_NUMERIC_STANDARD();
+	if (atof(patchlevel) + 0.00000999 < SvNV(sv))
+	    DIE("Perl %s required--this is only version %s, stopped",
+		SvPV(sv,na),patchlevel);
 	RETPUSHYES;
     }
     name = SvPV(sv, na);
@@ -2065,27 +2148,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 +2226,7 @@ PP(pp_require)
     compiling.cop_line = 0;
 
     PUTBACK;
-    return doeval(G_SCALAR);
+    return DOCATCH(doeval(G_SCALAR));
 }
 
 PP(pp_dofile)
@@ -2154,9 +2239,10 @@ PP(pp_entereval)
     dSP;
     register CONTEXT *cx;
     dPOPss;
-    I32 gimme = GIMME;
-    char tmpbuf[32];
+    I32 gimme = GIMME, was = sub_generation;
+    char tmpbuf[32], *safestr;
     STRLEN len;
+    OP *ret;
 
     if (!SvPV(sv,len) || !len)
 	RETPUSHUNDEF;
@@ -2169,10 +2255,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 +2277,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,6 +2293,7 @@ PP(pp_leaveeval)
     I32 gimme;
     register CONTEXT *cx;
     OP *retop;
+    U8 save_flags = op -> op_flags;
     I32 optype;
 
     POPBLOCK(cx,newpm);
@@ -2223,27 +2320,31 @@ PP(pp_leaveeval)
     }
     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;
+#ifdef DEBUGGING
+    assert(CvDEPTH(compcv) == 1);
+#endif
+    CvDEPTH(compcv) = 0;
 
-	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 &&
+	!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
+	char *name = cx->blk_eval.old_name;
 
-	    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 (!(save_flags & OPf_SPECIAL))
+	sv_setpv(GvSV(errgv),"");
 
     RETURNOP(retop);
 }
@@ -2264,7 +2365,8 @@ PP(pp_entertry)
 
     in_eval = 1;
     sv_setpv(GvSV(errgv),"");
-    RETURN;
+    PUTBACK;
+    return DOCATCH(op->op_next);
 }
 
 PP(pp_leavetry)
@@ -2301,7 +2403,7 @@ PP(pp_leavetry)
     }
     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 +2432,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 +2468,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 +2589,6 @@ SV *sv;
     }
     Copy(fops, s, arg, U16);
     Safefree(fops);
+    sv_magic(sv, Nullsv, 'f', Nullch, 0);
     SvCOMPILED_on(sv);
 }