X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=af6394d913653ba772f9d2527a5183eacf5fc212;hb=0453d815b8a74697ff1e5451c27aba2fe537b8e0;hp=fbfcab582768cb5bed9c32d92af7e1a357b538bb;hpb=127ad2b7f46b3b186ffbada86b1d7dda9ffd2a05;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index fbfcab5..af6394d 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-1999, 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.
@@ -17,6 +17,7 @@
  */
 
 #include "EXTERN.h"
+#define PERL_IN_PP_CTL_C
 #include "perl.h"
 
 #ifndef WORD_ALIGN
@@ -29,20 +30,6 @@
 #define CALLOP this->*PL_op
 #else
 #define CALLOP *PL_op
-static OP *docatch _((OP *o));
-static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
-static void doparseform _((SV *sv));
-static I32 dopoptoeval _((I32 startingblock));
-static I32 dopoptolabel _((char *label));
-static I32 dopoptoloop _((I32 startingblock));
-static I32 dopoptosub _((I32 startingblock));
-static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
-static void save_lines _((AV *array, SV *sv));
-static I32 sortcv _((SV *a, SV *b));
-static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
-static OP *doeval _((int gimme, OP** startop));
-static I32 amagic_cmp _((SV *str1, SV *str2));
-static I32 amagic_cmp_locale _((SV *str1, SV *str2));
 #endif
 
 PP(pp_wantarray)
@@ -114,7 +101,7 @@ PP(pp_regcomp)
 		PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 
 	    pm->op_pmflags = pm->op_pmpermflags;	/* reset case sensitivity */
-	    pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
+	    pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
 	    PL_reginterp_cnt = 0;		/* XXXX Be extra paranoid - needed
 					   inside tie/overload accessors.  */
 	}
@@ -156,17 +143,18 @@ PP(pp_substcont)
 
     if (cx->sb_iters++) {
 	if (cx->sb_iters > cx->sb_maxiters)
-	    DIE("Substitution loop");
+	    DIE(aTHX_ "Substitution loop");
 
 	if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 	    cx->sb_rxtainted |= 2;
 	sv_catsv(dstr, POPs);
 
 	/* Are we done */
-	if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
+	if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 				     s == m, cx->sb_targ, NULL,
 				     ((cx->sb_rflags & REXEC_COPY_STR)
-				      ? 0 : REXEC_COPY_STR)))
+				      ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
+				      : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 	{
 	    SV *targ = cx->sb_targ;
 	    sv_catpvn(dstr, s, cx->sb_strend - s);
@@ -194,23 +182,23 @@ PP(pp_substcont)
 	    RETURNOP(pm->op_next);
 	}
     }
-    if (rx->subbase && rx->subbase != orig) {
+    if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 	m = s;
 	s = orig;
-	cx->sb_orig = orig = rx->subbase;
+	cx->sb_orig = orig = rx->subbeg;
 	s = orig + (m - s);
 	cx->sb_strend = s + (cx->sb_strend - m);
     }
-    cx->sb_m = m = rx->startp[0];
+    cx->sb_m = m = rx->startp[0] + orig;
     sv_catpvn(dstr, s, m-s);
-    cx->sb_s = rx->endp[0];
+    cx->sb_s = rx->endp[0] + orig;
     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
     rxres_save(&cx->sb_rxres, rx);
     RETURNOP(pm->op_pmreplstart);
 }
 
 void
-rxres_save(void **rsp, REGEXP *rx)
+Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 {
     UV *p = (UV*)*rsp;
     U32 i;
@@ -224,13 +212,13 @@ rxres_save(void **rsp, REGEXP *rx)
 	*rsp = (void*)p;
     }
 
-    *p++ = (UV)rx->subbase;
-    rx->subbase = Nullch;
+    *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
+    RX_MATCH_COPIED_off(rx);
 
     *p++ = rx->nparens;
 
     *p++ = (UV)rx->subbeg;
-    *p++ = (UV)rx->subend;
+    *p++ = (UV)rx->sublen;
     for (i = 0; i <= rx->nparens; ++i) {
 	*p++ = (UV)rx->startp[i];
 	*p++ = (UV)rx->endp[i];
@@ -238,27 +226,28 @@ rxres_save(void **rsp, REGEXP *rx)
 }
 
 void
-rxres_restore(void **rsp, REGEXP *rx)
+Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 {
     UV *p = (UV*)*rsp;
     U32 i;
 
-    Safefree(rx->subbase);
-    rx->subbase = (char*)(*p);
+    if (RX_MATCH_COPIED(rx))
+	Safefree(rx->subbeg);
+    RX_MATCH_COPIED_set(rx, *p);
     *p++ = 0;
 
     rx->nparens = *p++;
 
     rx->subbeg = (char*)(*p++);
-    rx->subend = (char*)(*p++);
+    rx->sublen = (I32)(*p++);
     for (i = 0; i <= rx->nparens; ++i) {
-	rx->startp[i] = (char*)(*p++);
-	rx->endp[i] = (char*)(*p++);
+	rx->startp[i] = (I32)(*p++);
+	rx->endp[i] = (I32)(*p++);
     }
 }
 
 void
-rxres_free(void **rsp)
+Perl_rxres_free(pTHX_ void **rsp)
 {
     UV *p = (UV*)*rsp;
 
@@ -287,7 +276,7 @@ PP(pp_formline)
     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
     char *chophere;
     char *linemark;
-    double value;
+    NV value;
     bool gotsome;
     STRLEN len;
     STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
@@ -361,7 +350,7 @@ PP(pp_formline)
 	    else {
 		sv = &PL_sv_no;
 		if (ckWARN(WARN_SYNTAX))
-		    warner(WARN_SYNTAX, "Not enough format arguments");
+		    Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
 	    }
 	    break;
 
@@ -578,11 +567,25 @@ 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 {
-		sprintf(t, "%*.0f", (int) fieldsize, value);
+	    {
+		RESTORE_NUMERIC_LOCAL();
+#if defined(USE_LONG_DOUBLE)
+		if (arg & 256) {
+		    sprintf(t, "%#*.*Lf",
+			    (int) fieldsize, (int) arg & 255, value);
+		} else {
+		    sprintf(t, "%*.0Lf", (int) fieldsize, value);
+		}
+#else
+		if (arg & 256) {
+		    sprintf(t, "%#*.*f",
+			    (int) fieldsize, (int) arg & 255, value);
+		} else {
+		    sprintf(t, "%*.0f",
+			    (int) fieldsize, value);
+		}
+#endif
+		RESTORE_NUMERIC_STANDARD();
 	    }
 	    t += fieldsize;
 	    break;
@@ -604,7 +607,7 @@ PP(pp_formline)
 		    if (lines == 200) {
 			arg = t - linemark;
 			if (strnEQ(linemark, linemark - arg, arg))
-			    DIE("Runaway format");
+			    DIE(aTHX_ "Runaway format");
 		    }
 		    FmLINES(PL_formtarget) = lines;
 		    SP = ORIGMARK;
@@ -660,12 +663,12 @@ PP(pp_grepstart)
     if (PL_stack_base + *PL_markstack_ptr == SP) {
 	(void)POPMARK;
 	if (GIMME_V == G_SCALAR)
-	    XPUSHs(&PL_sv_no);
+	    XPUSHs(sv_2mortal(newSViv(0)));
 	RETURNOP(PL_op->op_next->op_next);
     }
     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
-    pp_pushmark(ARGS);				/* push dst */
-    pp_pushmark(ARGS);				/* push src */
+    pp_pushmark();				/* push dst */
+    pp_pushmark();				/* push src */
     ENTER;					/* enter outer scope */
 
     SAVETMPS;
@@ -680,13 +683,13 @@ PP(pp_grepstart)
 
     PUTBACK;
     if (PL_op->op_type == OP_MAPSTART)
-	pp_pushmark(ARGS);			/* push top */
+	pp_pushmark();			/* push top */
     return ((LOGOP*)PL_op->op_next)->op_other;
 }
 
 PP(pp_mapstart)
 {
-    DIE("panic: mapstart");	/* uses grepstart */
+    DIE(aTHX_ "panic: mapstart");	/* uses grepstart */
 }
 
 PP(pp_mapwhile)
@@ -752,6 +755,21 @@ PP(pp_mapwhile)
     }
 }
 
+STATIC I32
+S_sv_ncmp(pTHX_ SV *a, SV *b)
+{
+    NV nv1 = SvNV(a);
+    NV nv2 = SvNV(b);
+    return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
+}
+
+STATIC I32
+S_sv_i_ncmp(pTHX_ SV *a, SV *b)
+{
+    IV iv1 = SvIV(a);
+    IV iv2 = SvIV(b);
+    return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
+}
 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
 	  *svp = Nullsv;				\
           if (PL_amagic_generation) { \
@@ -764,12 +782,56 @@ PP(pp_mapwhile)
 	} STMT_END
 
 STATIC I32
-amagic_cmp(register SV *str1, register SV *str2)
+S_amagic_ncmp(pTHX_ register SV *a, register SV *b)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
+    if (tmpsv) {
+    	NV d;
+    	
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+     }
+     return sv_ncmp(a, b);
+}
+
+STATIC I32
+S_amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
+    if (tmpsv) {
+    	NV d;
+    	
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+    }
+    return sv_i_ncmp(a, b);
+}
+
+STATIC I32
+S_amagic_cmp(pTHX_ register SV *str1, register SV *str2)
 {
     SV *tmpsv;
     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
     if (tmpsv) {
-    	double d;
+    	NV d;
     	
         if (SvIOK(tmpsv)) {
             I32 i = SvIVX(tmpsv);
@@ -786,12 +848,12 @@ amagic_cmp(register SV *str1, register SV *str2)
 }
 
 STATIC I32
-amagic_cmp_locale(register SV *str1, register SV *str2)
+S_amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
 {
     SV *tmpsv;
     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
     if (tmpsv) {
-    	double d;
+    	NV d;
     	
         if (SvIOK(tmpsv)) {
             I32 i = SvIVX(tmpsv);
@@ -842,16 +904,16 @@ PP(pp_sort)
 		    SV *tmpstr = sv_newmortal();
 		    gv_efullname3(tmpstr, gv, Nullch);
 		    if (cv && CvXSUB(cv))
-			DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
-		    DIE("Undefined sort subroutine \"%s\" called",
+			DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
+		    DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
 			SvPVX(tmpstr));
 		}
 		if (cv) {
 		    if (CvXSUB(cv))
-			DIE("Xsub called in sort");
-		    DIE("Undefined subroutine in sort");
+			DIE(aTHX_ "Xsub called in sort");
+		    DIE(aTHX_ "Undefined subroutine in sort");
 		}
-		DIE("Not a CODE reference in sort");
+		DIE(aTHX_ "Not a CODE reference in sort");
 	    }
 	    PL_sortcop = CvSTART(cv);
 	    SAVESPTR(CvROOT(cv)->op_ppaddr);
@@ -872,10 +934,11 @@ PP(pp_sort)
 	if (*up = *++MARK) {			/* Weed out nulls. */
 	    SvTEMP_off(*up);
 	    if (!PL_sortcop && !SvPOK(*up)) {
+		STRLEN n_a;
 	        if (SvAMAGIC(*up))
 	            overloading = 1;
 	        else
-		    (void)sv_2pv(*up, &PL_na);
+		    (void)sv_2pv(*up, &n_a);
 	    }
 	    up++;
 	}
@@ -911,7 +974,7 @@ PP(pp_sort)
 		    (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
 	    }
 	    PL_sortcxix = cxstack_ix;
-	    qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
+	    qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(S_sortcv));
 
 	    POPBLOCK(cx,PL_curpm);
 	    PL_stack_sp = newsp;
@@ -923,13 +986,30 @@ PP(pp_sort)
 	if (max > 1) {
 	    MEXTEND(SP, 20);	/* Can't afford stack realloc on signal. */
 	    qsortsv(ORIGMARK+1, max,
-		    (PL_op->op_private & OPpLOCALE)
-		    ? ( overloading
-		        ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
-		        : FUNC_NAME_TO_PTR(sv_cmp_locale))
-		    : ( overloading 
-		        ? FUNC_NAME_TO_PTR(amagic_cmp)
-		        : FUNC_NAME_TO_PTR(sv_cmp) ));
+ 		    (PL_op->op_private & OPpSORT_NUMERIC)
+			? ( (PL_op->op_private & OPpSORT_INTEGER)
+			    ? ( overloading
+				? FUNC_NAME_TO_PTR(S_amagic_i_ncmp)
+				: FUNC_NAME_TO_PTR(S_sv_i_ncmp))
+			    : ( overloading
+				? FUNC_NAME_TO_PTR(S_amagic_ncmp)
+				: FUNC_NAME_TO_PTR(S_sv_ncmp)))
+			: ( (PL_op->op_private & OPpLOCALE)
+			    ? ( overloading
+				? FUNC_NAME_TO_PTR(S_amagic_cmp_locale)
+				: FUNC_NAME_TO_PTR(Perl_sv_cmp_locale))
+			    : ( overloading
+				? FUNC_NAME_TO_PTR(S_amagic_cmp)
+		    : FUNC_NAME_TO_PTR(Perl_sv_cmp) )));
+	    if (PL_op->op_private & OPpSORT_REVERSE) {
+		SV **p = ORIGMARK+1;
+		SV **q = ORIGMARK+max;
+		while (p < q) {
+		    SV *tmp = *p;
+		    *p++ = *q;
+		    *q-- = tmp;
+		}
+	    }
 	}
     }
     LEAVE;
@@ -942,8 +1022,11 @@ PP(pp_sort)
 PP(pp_range)
 {
     if (GIMME == G_ARRAY)
-	return cCONDOP->op_true;
-    return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+	return NORMAL;
+    if (SvTRUEx(PAD_SV(PL_op->op_targ)))
+	return cLOGOP->op_other;
+    else
+	return NORMAL;
 }
 
 PP(pp_flip)
@@ -951,7 +1034,7 @@ PP(pp_flip)
     djSP;
 
     if (GIMME == G_ARRAY) {
-	RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
+	RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
     }
     else {
 	dTOPss;
@@ -969,7 +1052,7 @@ PP(pp_flip)
 	    else {
 		sv_setiv(targ, 0);
 		SP--;
-		RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
+		RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 	    }
 	}
 	sv_setpv(TARG, "");
@@ -984,33 +1067,41 @@ PP(pp_flop)
 
     if (GIMME == G_ARRAY) {
 	dPOPPOPssrl;
-	register I32 i;
+	register I32 i, j;
 	register SV *sv;
 	I32 max;
 
+	if (SvGMAGICAL(left))
+	    mg_get(left);
+	if (SvGMAGICAL(right))
+	    mg_get(right);
+
 	if (SvNIOKp(left) || !SvPOKp(left) ||
 	  (looks_like_number(left) && *SvPVX(left) != '0') )
 	{
-	    if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
-		croak("Range iterator outside integer range");
+	    if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
+		Perl_croak(aTHX_ "Range iterator outside integer range");
 	    i = SvIV(left);
 	    max = SvIV(right);
 	    if (max >= i) {
-		EXTEND_MORTAL(max - i + 1);
-		EXTEND(SP, max - i + 1);
+		j = max - i + 1;
+		EXTEND_MORTAL(j);
+		EXTEND(SP, j);
 	    }
-	    while (i <= max) {
+	    else
+		j = 0;
+	    while (j--) {
 		sv = sv_2mortal(newSViv(i++));
 		PUSHs(sv);
 	    }
 	}
 	else {
 	    SV *final = sv_mortalcopy(right);
-	    STRLEN len;
+	    STRLEN len, n_a;
 	    char *tmps = SvPV(final, len);
 
 	    sv = sv_mortalcopy(left);
-	    SvPV_force(sv,PL_na);
+	    SvPV_force(sv,n_a);
 	    while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
 		XPUSHs(sv);
 	        if (strEQ(SvPVX(sv),tmps))
@@ -1039,7 +1130,7 @@ PP(pp_flop)
 /* Control. */
 
 STATIC I32
-dopoptolabel(char *label)
+S_dopoptolabel(pTHX_ char *label)
 {
     dTHR;
     register I32 i;
@@ -1050,32 +1141,32 @@ dopoptolabel(char *label)
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting substitution via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting subroutine via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting eval via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting pseudo-block via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
 			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
 	    if (!cx->blk_loop.label ||
 	      strNE(label, cx->blk_loop.label) ) {
-		DEBUG_l(deb("(Skipping label #%ld %s)\n",
+		DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
 			(long)i, cx->blk_loop.label));
 		continue;
 	    }
-	    DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
+	    DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
 	    return i;
 	}
     }
@@ -1083,14 +1174,14 @@ dopoptolabel(char *label)
 }
 
 I32
-dowantarray(void)
+Perl_dowantarray(pTHX)
 {
     I32 gimme = block_gimme();
     return (gimme == G_VOID) ? G_SCALAR : gimme;
 }
 
 I32
-block_gimme(void)
+Perl_block_gimme(pTHX)
 {
     dTHR;
     I32 cxix;
@@ -1107,21 +1198,21 @@ block_gimme(void)
     case G_ARRAY:
 	return G_ARRAY;
     default:
-	croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
+	Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
 	/* NOTREACHED */
 	return 0;
     }
 }
 
 STATIC I32
-dopoptosub(I32 startingblock)
+S_dopoptosub(pTHX_ I32 startingblock)
 {
     dTHR;
     return dopoptosub_at(cxstack, startingblock);
 }
 
 STATIC I32
-dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
+S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
 {
     dTHR;
     I32 i;
@@ -1133,7 +1224,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
 	    continue;
 	case CXt_EVAL:
 	case CXt_SUB:
-	    DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
+	    DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -1141,7 +1232,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
 }
 
 STATIC I32
-dopoptoeval(I32 startingblock)
+S_dopoptoeval(pTHX_ I32 startingblock)
 {
     dTHR;
     I32 i;
@@ -1152,7 +1243,7 @@ dopoptoeval(I32 startingblock)
 	default:
 	    continue;
 	case CXt_EVAL:
-	    DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
+	    DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -1160,7 +1251,7 @@ dopoptoeval(I32 startingblock)
 }
 
 STATIC I32
-dopoptoloop(I32 startingblock)
+S_dopoptoloop(pTHX_ I32 startingblock)
 {
     dTHR;
     I32 i;
@@ -1170,26 +1261,26 @@ dopoptoloop(I32 startingblock)
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting substitution via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting subroutine via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting eval via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
 	    if (ckWARN(WARN_UNSAFE))
-		warner(WARN_UNSAFE, "Exiting pseudo-block via %s", 
+		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
 			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
-	    DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
+	    DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -1197,7 +1288,7 @@ dopoptoloop(I32 startingblock)
 }
 
 void
-dounwind(I32 cxix)
+Perl_dounwind(pTHX_ I32 cxix)
 {
     dTHR;
     register PERL_CONTEXT *cx;
@@ -1229,10 +1320,47 @@ dounwind(I32 cxix)
     }
 }
 
+/*
+ * Closures mentioned at top level of eval cannot be referenced
+ * again, and their presence indirectly causes a memory leak.
+ * (Note that the fact that compcv and friends are still set here
+ * is, AFAIK, an accident.)  --Chip
+ *
+ * XXX need to get comppad et al from eval's cv rather than
+ * relying on the incidental global values.
+ */
+STATIC void
+S_free_closures(pTHX)
+{
+    dTHR;
+    SV **svp = AvARRAY(PL_comppad_name);
+    I32 ix;
+    for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
+	SV *sv = svp[ix];
+	if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
+	    SvREFCNT_dec(sv);
+	    svp[ix] = &PL_sv_undef;
+
+	    sv = PL_curpad[ix];
+	    if (CvCLONE(sv)) {
+		SvREFCNT_dec(CvOUTSIDE(sv));
+		CvOUTSIDE(sv) = Nullcv;
+	    }
+	    else {
+		SvREFCNT_dec(sv);
+		sv = NEWSV(0,0);
+		SvPADTMP_on(sv);
+		PL_curpad[ix] = sv;
+	    }
+	}
+    }
+}
+
 OP *
-die_where(char *message)
+Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
     dSP;
+    STRLEN n_a;
     if (PL_in_eval) {
 	I32 cxix;
 	register PERL_CONTEXT *cx;
@@ -1240,11 +1368,10 @@ die_where(char *message)
 	SV **newsp;
 
 	if (message) {
-	    if (PL_in_eval & 4) {
+	    if (PL_in_eval & EVAL_KEEPERR) {
 		SV **svp;
-		STRLEN klen = strlen(message);
 		
-		svp = hv_fetch(ERRHV, message, klen, TRUE);
+		svp = hv_fetch(ERRHV, message, msglen, TRUE);
 		if (svp) {
 		    if (!SvIOK(*svp)) {
 			static char prefix[] = "\t(in cleanup) ";
@@ -1253,22 +1380,22 @@ die_where(char *message)
 			(void)SvIOK_only(*svp);
 			if (!SvPOK(err))
 			    sv_setpv(err,"");
-			SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
+			SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
 			sv_catpvn(err, prefix, sizeof(prefix)-1);
-			sv_catpvn(err, message, klen);
+			sv_catpvn(err, message, msglen);
 			if (ckWARN(WARN_UNSAFE)) {
-			    STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
-			    warner(WARN_UNSAFE, SvPVX(err)+start);
+			    STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
+			    Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
 			}
 		    }
 		    sv_inc(*svp);
 		}
 	    }
 	    else
-		sv_setpv(ERRSV, message);
+		sv_setpvn(ERRSV, message, msglen);
 	}
 	else
-	    message = SvPVx(ERRSV, PL_na);
+	    message = SvPVx(ERRSV, msglen);
 
 	while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
 	    dounwind(-1);
@@ -1283,7 +1410,8 @@ die_where(char *message)
 
 	    POPBLOCK(cx,PL_curpm);
 	    if (CxTYPE(cx) != CXt_EVAL) {
-		PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
+		PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
+		PerlIO_write(PerlIO_stderr(), message, msglen);
 		my_exit(1);
 	    }
 	    POPEVAL(cx);
@@ -1295,16 +1423,25 @@ die_where(char *message)
 	    LEAVE;
 
 	    if (optype == OP_REQUIRE) {
-		char* msg = SvPVx(ERRSV, PL_na);
-		DIE("%s", *msg ? msg : "Compilation failed in require");
+		char* msg = SvPVx(ERRSV, n_a);
+		DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
 	    }
 	    return pop_return();
 	}
     }
     if (!message)
-	message = SvPVx(ERRSV, PL_na);
-    PerlIO_printf(PerlIO_stderr(), "%s",message);
-    PerlIO_flush(PerlIO_stderr());
+	message = SvPVx(ERRSV, msglen);
+    {
+#ifdef USE_SFIO
+	/* SFIO can really mess with your errno */
+	int e = errno;
+#endif
+	PerlIO_write(PerlIO_stderr(), message, msglen);
+	(void)PerlIO_flush(PerlIO_stderr());
+#ifdef USE_SFIO
+	errno = e;
+#endif
+    }
     my_failure_exit();
     /* NOTREACHED */
     return 0;
@@ -1352,7 +1489,7 @@ PP(pp_caller)
 
     if (MAXARG)
 	count = POPi;
-    EXTEND(SP, 6);
+    EXTEND(SP, 7);
     for (;;) {
 	/* we may be in a higher stacklevel, so dig down deeper */
 	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -1399,7 +1536,8 @@ PP(pp_caller)
 	PUSHs(&PL_sv_undef);
     else
 	PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
-    PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
+    PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
+			      SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
     if (!MAXARG)
 	RETURN;
@@ -1410,7 +1548,7 @@ PP(pp_caller)
 	PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
     }
     else {
-	PUSHs(sv_2mortal(newSVpv("(eval)",0)));
+	PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
 	PUSHs(sv_2mortal(newSViv(0)));
     }
     gimme = (I32)cx->blk_gimme;
@@ -1449,11 +1587,16 @@ PP(pp_caller)
 	Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
 	AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
     }
+    /* XXX only hints propagated via op_private are currently
+     * visible (others are not easily accessible, since they
+     * use the global PL_hints) */
+    PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
+			     HINT_PRIVATE_MASK)));
     RETURN;
 }
 
 STATIC I32
-sortcv(SV *a, SV *b)
+S_sortcv(pTHX_ SV *a, SV *b)
 {
     dTHR;
     I32 oldsaveix = PL_savestack_ix;
@@ -1463,11 +1606,11 @@ sortcv(SV *a, SV *b)
     GvSV(PL_secondgv) = b;
     PL_stack_sp = PL_stack_base;
     PL_op = PL_sortcop;
-    CALLRUNOPS();
+    CALLRUNOPS(aTHX);
     if (PL_stack_sp != PL_stack_base + 1)
-	croak("Sort subroutine didn't return single value");
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
     if (!SvNIOKp(*PL_stack_sp))
-	croak("Sort subroutine didn't return a numeric value");
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
     result = SvIV(*PL_stack_sp);
     while (PL_scopestack_ix > oldscopeix) {
 	LEAVE;
@@ -1480,11 +1623,12 @@ PP(pp_reset)
 {
     djSP;
     char *tmps;
+    STRLEN n_a;
 
     if (MAXARG < 1)
 	tmps = "";
     else
-	tmps = POPp;
+	tmps = POPpx;
     sv_reset(tmps, PL_curcop->cop_stash);
     PUSHs(&PL_sv_yes);
     RETURN;
@@ -1514,7 +1658,7 @@ PP(pp_dbstate)
 	gv = PL_DBgv;
 	cv = GvCV(gv);
 	if (!cv)
-	    DIE("No DB::DB routine defined");
+	    DIE(aTHX_ "No DB::DB routine defined");
 
 	if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
 	    return NORMAL;
@@ -1557,8 +1701,12 @@ PP(pp_enteriter)
     SAVETMPS;
 
 #ifdef USE_THREADS
-    if (PL_op->op_flags & OPf_SPECIAL)
-	svp = save_threadsv(PL_op->op_targ);	/* per-thread variable */
+    if (PL_op->op_flags & OPf_SPECIAL) {
+	dTHR;
+	svp = &THREADSV(PL_op->op_targ);	/* per-thread variable */
+	SAVEGENERICSV(*svp);
+	*svp = NEWSV(0,0);
+    }
     else
 #endif /* USE_THREADS */
     if (PL_op->op_targ) {
@@ -1566,9 +1714,9 @@ PP(pp_enteriter)
 	SAVESPTR(*svp);
     }
     else {
-	GV *gv = (GV*)POPs;
-	(void)save_scalar(gv);
-	svp = &GvSV(gv);			/* symbol table variable */
+	svp = &GvSV((GV*)POPs);			/* symbol table variable */
+	SAVEGENERICSV(*svp);
+	*svp = NEWSV(0,0);
     }
 
     ENTER;
@@ -1583,7 +1731,7 @@ PP(pp_enteriter)
 		(looks_like_number(sv) && *SvPVX(sv) != '0')) {
 		 if (SvNV(sv) < IV_MIN ||
 		     SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
-		     croak("Range iterator outside integer range");
+		     Perl_croak(aTHX_ "Range iterator outside integer range");
 		 cx->blk_loop.iterix = SvIV(sv);
 		 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
 	    }
@@ -1681,7 +1829,7 @@ PP(pp_return)
 
     cxix = dopoptosub(cxstack_ix);
     if (cxix < 0)
-	DIE("Can't return outside a subroutine");
+	DIE(aTHX_ "Can't return outside a subroutine");
     if (cxix < cxstack_ix)
 	dounwind(cxix);
 
@@ -1693,17 +1841,20 @@ PP(pp_return)
 	break;
     case CXt_EVAL:
 	POPEVAL(cx);
+	if (AvFILLp(PL_comppad_name) >= 0)
+	    free_closures();
+	lex_end();
 	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(PL_incgv), name, strlen(name), G_DISCARD);
-	    DIE("%s did not return a true value", name);
+	    DIE(aTHX_ "%s did not return a true value", name);
 	}
 	break;
     default:
-	DIE("panic: return");
+	DIE(aTHX_ "panic: return");
     }
 
     TAINT_NOT;
@@ -1763,12 +1914,12 @@ PP(pp_last)
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
 	if (cxix < 0)
-	    DIE("Can't \"last\" outside a block");
+	    DIE(aTHX_ "Can't \"last\" outside a block");
     }
     else {
 	cxix = dopoptolabel(cPVOP->op_pv);
 	if (cxix < 0)
-	    DIE("Label not found for \"last %s\"", cPVOP->op_pv);
+	    DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
     }
     if (cxix < cxstack_ix)
 	dounwind(cxix);
@@ -1790,7 +1941,7 @@ PP(pp_last)
 	nextop = pop_return();
 	break;
     default:
-	DIE("panic: last");
+	DIE(aTHX_ "panic: last");
     }
 
     TAINT_NOT;
@@ -1836,12 +1987,12 @@ PP(pp_next)
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
 	if (cxix < 0)
-	    DIE("Can't \"next\" outside a block");
+	    DIE(aTHX_ "Can't \"next\" outside a block");
     }
     else {
 	cxix = dopoptolabel(cPVOP->op_pv);
 	if (cxix < 0)
-	    DIE("Label not found for \"next %s\"", cPVOP->op_pv);
+	    DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
     }
     if (cxix < cxstack_ix)
 	dounwind(cxix);
@@ -1861,12 +2012,12 @@ PP(pp_redo)
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
 	if (cxix < 0)
-	    DIE("Can't \"redo\" outside a block");
+	    DIE(aTHX_ "Can't \"redo\" outside a block");
     }
     else {
 	cxix = dopoptolabel(cPVOP->op_pv);
 	if (cxix < 0)
-	    DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
+	    DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
     }
     if (cxix < cxstack_ix)
 	dounwind(cxix);
@@ -1878,14 +2029,14 @@ PP(pp_redo)
 }
 
 STATIC OP *
-dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
+S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
 {
     OP *kid;
     OP **ops = opstack;
     static char too_deep[] = "Target of goto is too deeply nested";
 
     if (ops >= oplimit)
-	croak(too_deep);
+	Perl_croak(aTHX_ too_deep);
     if (o->op_type == OP_LEAVE ||
 	o->op_type == OP_SCOPE ||
 	o->op_type == OP_LEAVELOOP ||
@@ -1893,7 +2044,7 @@ dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
     {
 	*ops++ = cUNOPo->op_first;
 	if (ops >= oplimit)
-	    croak(too_deep);
+	    Perl_croak(aTHX_ too_deep);
     }
     *ops = 0;
     if (o->op_flags & OPf_KIDS) {
@@ -1922,7 +2073,7 @@ dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
 
 PP(pp_dump)
 {
-    return pp_goto(ARGS);
+    return pp_goto();
     /*NOTREACHED*/
 }
 
@@ -1936,10 +2087,12 @@ PP(pp_goto)
     OP *enterops[GOTO_DEPTH];
     char *label;
     int do_dump = (PL_op->op_type == OP_DUMP);
+    static char must_have_label[] = "goto must have label";
 
     label = 0;
     if (PL_op->op_flags & OPf_STACKED) {
 	SV *sv = POPs;
+	STRLEN n_a;
 
 	/* This egregious kludge implements goto &subroutine */
 	if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
@@ -1966,20 +2119,20 @@ PP(pp_goto)
 			goto retry;
 		    tmpstr = sv_newmortal();
 		    gv_efullname3(tmpstr, gv, Nullch);
-		    DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
+		    DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
 		}
-		DIE("Goto undefined subroutine");
+		DIE(aTHX_ "Goto undefined subroutine");
 	    }
 
 	    /* First do some returnish stuff. */
 	    cxix = dopoptosub(cxstack_ix);
 	    if (cxix < 0)
-		DIE("Can't goto subroutine outside a subroutine");
+		DIE(aTHX_ "Can't goto subroutine outside a subroutine");
 	    if (cxix < cxstack_ix)
 		dounwind(cxix);
 	    TOPBLOCK(cx);
 	    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
-		DIE("Can't goto subroutine from an eval-string");
+		DIE(aTHX_ "Can't goto subroutine from an eval-string");
 	    mark = PL_stack_sp;
 	    if (CxTYPE(cx) == CXt_SUB &&
 		cx->blk_sub.hasargs) {   /* put @_ back onto stack */
@@ -2023,26 +2176,29 @@ PP(pp_goto)
 	    /* Now do some callish stuff. */
 	    SAVETMPS;
 	    if (CvXSUB(cv)) {
+#ifdef PERL_XSUB_OLDSTYLE
 		if (CvOLDSTYLE(cv)) {
-		    I32 (*fp3)_((int,int,int));
+		    I32 (*fp3)(int,int,int);
 		    while (SP > mark) {
 			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);
 		    SP = PL_stack_base + items;
 		}
-		else {
+		else
+#endif /* PERL_XSUB_OLDSTYLE */
+		{
 		    SV **newsp;
 		    I32 gimme;
 
 		    PL_stack_sp--;		/* There is no cv arg. */
 		    /* Push a mark for the start of arglist */
 		    PUSHMARK(mark); 
-		    (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
+		    (void)(*CvXSUB(cv))(aTHXo_ cv);
 		    /* Pop the current context like a decent sub should */
 		    POPBLOCK(cx, PL_curpm);
 		    /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
@@ -2179,21 +2335,24 @@ PP(pp_goto)
 			gv_efullname3(sv, CvGV(cv), Nullch);
 		    }
 		    if (  PERLDB_GOTO
-			  && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
+			  && (gotocv = get_cv("DB::goto", FALSE)) ) {
 			PUSHMARK( PL_stack_sp );
-			perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
+			call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
 			PL_stack_sp--;
 		    }
 		}
 		RETURNOP(CvSTART(cv));
 	    }
 	}
-	else
-	    label = SvPV(sv,PL_na);
+	else {
+	    label = SvPV(sv,n_a);
+	    if (!(do_dump || *label))
+		DIE(aTHX_ must_have_label);
+	}
     }
     else if (PL_op->op_flags & OPf_SPECIAL) {
 	if (! do_dump)
-	    DIE("goto must have label");
+	    DIE(aTHX_ must_have_label);
     }
     else
 	label = cPVOP->op_pv;
@@ -2229,10 +2388,10 @@ PP(pp_goto)
 		}
 		/* FALL THROUGH */
 	    case CXt_NULL:
-		DIE("Can't \"goto\" outside a block");
+		DIE(aTHX_ "Can't \"goto\" outside a block");
 	    default:
 		if (ix)
-		    DIE("panic: goto");
+		    DIE(aTHX_ "panic: goto");
 		gotoprobe = PL_main_root;
 		break;
 	    }
@@ -2243,7 +2402,7 @@ PP(pp_goto)
 	    PL_lastgotoprobe = gotoprobe;
 	}
 	if (!retop)
-	    DIE("Can't find label %s", label);
+	    DIE(aTHX_ "Can't find label %s", label);
 
 	/* pop unwanted frames */
 
@@ -2267,9 +2426,9 @@ PP(pp_goto)
 		/* Eventually we may want to stack the needed arguments
 		 * for each op.  For now, we punt on the hard ones. */
 		if (PL_op->op_type == OP_ENTERITER)
-		    DIE("Can't \"goto\" into the middle of a foreach loop",
+		    DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
 			label);
-		(CALLOP->op_ppaddr)(ARGS);
+		(CALLOP->op_ppaddr)(aTHX);
 	    }
 	    PL_op = oldop;
 	}
@@ -2314,11 +2473,11 @@ PP(pp_exit)
 PP(pp_nswitch)
 {
     djSP;
-    double value = SvNVx(GvSV(cCOP->cop_gv));
+    NV value = SvNVx(GvSV(cCOP->cop_gv));
     register I32 match = I_32(value);
 
     if (value < 0.0) {
-	if (((double)match) > value)
+	if (((NV)match) > value)
 	    --match;		/* was fractional--truncate other way */
     }
     match -= cCOP->uop.scop.scop_offset;
@@ -2338,7 +2497,8 @@ PP(pp_cswitch)
     if (PL_multiline)
 	PL_op = PL_op->op_next;			/* can't assume anything */
     else {
-	match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
+	STRLEN n_a;
+	match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
 	match -= cCOP->uop.scop.scop_offset;
 	if (match < 0)
 	    match = 0;
@@ -2353,7 +2513,7 @@ PP(pp_cswitch)
 /* Eval. */
 
 STATIC void
-save_lines(AV *array, SV *sv)
+S_save_lines(pTHX_ AV *array, SV *sv)
 {
     register char *s = SvPVX(sv);
     register char *send = SvPVX(sv) + SvCUR(sv);
@@ -2376,44 +2536,47 @@ save_lines(AV *array, SV *sv)
     }
 }
 
+STATIC void *
+S_docatch_body(pTHX_ va_list args)
+{
+    CALLRUNOPS(aTHX);
+    return NULL;
+}
+
 STATIC OP *
-docatch(OP *o)
+S_docatch(pTHX_ OP *o)
 {
     dTHR;
     int ret;
     OP *oldop = PL_op;
-    dJMPENV;
 
-    PL_op = o;
 #ifdef DEBUGGING
     assert(CATCH_GET == TRUE);
-    DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
 #endif
-    JMPENV_PUSH(ret);
+    PL_op = o;
+ redo_body:
+    CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_docatch_body));
     switch (ret) {
-    default:				/* topmost level handles it */
-pass_the_buck:
-	JMPENV_POP;
+    case 0:
+	break;
+    case 3:
+	if (PL_restartop) {
+	    PL_op = PL_restartop;
+	    PL_restartop = 0;
+	    goto redo_body;
+	}
+	/* FALL THROUGH */
+    default:
 	PL_op = oldop;
 	JMPENV_JUMP(ret);
 	/* NOTREACHED */
-    case 3:
-	if (!PL_restartop)
-	    goto pass_the_buck;
-	PL_op = PL_restartop;
-	PL_restartop = 0;
-	/* FALL THROUGH */
-    case 0:
-        CALLRUNOPS();
-	break;
     }
-    JMPENV_POP;
     PL_op = oldop;
     return Nullop;
 }
 
 OP *
-sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
+Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
 /* sv Text to convert to OP tree. */
 /* startop op_free() this to undo. */
 /* code Short string id of the caller. */
@@ -2481,7 +2644,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
 
 /* With USE_THREADS, eval_owner must be held on entry to doeval */
 STATIC OP *
-doeval(int gimme, OP** startop)
+S_doeval(pTHX_ int gimme, OP** startop)
 {
     dSP;
     OP *saveop = PL_op;
@@ -2490,7 +2653,7 @@ doeval(int gimme, OP** startop)
     AV* comppadlist;
     I32 i;
 
-    PL_in_eval = 1;
+    PL_in_eval = EVAL_INEVAL;
 
     PUSHMARK(SP);
 
@@ -2518,7 +2681,7 @@ doeval(int gimme, OP** startop)
     SAVESPTR(PL_compcv);
     PL_compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
-    CvUNIQUE_on(PL_compcv);
+    CvEVAL_on(PL_compcv);
 #ifdef USE_THREADS
     CvOWNER(PL_compcv) = 0;
     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
@@ -2533,7 +2696,7 @@ doeval(int gimme, OP** startop)
     PL_min_intro_pending = 0;
     PL_padix = 0;
 #ifdef USE_THREADS
-    av_store(PL_comppad_name, 0, newSVpv("@_", 2));
+    av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
     PL_curpad[0] = (SV*)newAV();
     SvPADMY_on(PL_curpad[0]);	/* XXX Needed? */
 #endif /* USE_THREADS */
@@ -2567,9 +2730,9 @@ doeval(int gimme, OP** startop)
     PL_curcop = &PL_compiling;
     PL_curcop->cop_arybase = 0;
     SvREFCNT_dec(PL_rs);
-    PL_rs = newSVpv("\n", 1);
+    PL_rs = newSVpvn("\n", 1);
     if (saveop && saveop->op_flags & OPf_SPECIAL)
-	PL_in_eval |= 4;
+	PL_in_eval |= EVAL_KEEPERR;
     else
 	sv_setpv(ERRSV,"");
     if (yyparse() || PL_error_count || !PL_eval_root) {
@@ -2577,7 +2740,8 @@ doeval(int gimme, OP** startop)
 	I32 gimme;
 	PERL_CONTEXT *cx;
 	I32 optype = 0;			/* Might be reset by POPEVAL. */
-
+	STRLEN n_a;
+	
 	PL_op = saveop;
 	if (PL_eval_root) {
 	    op_free(PL_eval_root);
@@ -2592,14 +2756,14 @@ doeval(int gimme, OP** startop)
 	lex_end();
 	LEAVE;
 	if (optype == OP_REQUIRE) {
-	    char* msg = SvPVx(ERRSV, PL_na);
-	    DIE("%s", *msg ? msg : "Compilation failed in require");
+	    char* msg = SvPVx(ERRSV, n_a);
+	    DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
 	} else if (startop) {
-	    char* msg = SvPVx(ERRSV, PL_na);
+	    char* msg = SvPVx(ERRSV, n_a);
 
 	    POPBLOCK(cx,PL_curpm);
 	    POPEVAL(cx);
-	    croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
+	    Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
 	}
 	SvREFCNT_dec(PL_rs);
 	PL_rs = SvREFCNT_inc(PL_nrs);
@@ -2631,13 +2795,13 @@ doeval(int gimme, OP** startop)
 
     /* Register with debugger: */
     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
-	CV *cv = perl_get_cv("DB::postponed", FALSE);
+	CV *cv = get_cv("DB::postponed", FALSE);
 	if (cv) {
 	    dSP;
 	    PUSHMARK(SP);
 	    XPUSHs((SV*)PL_compiling.cop_filegv);
 	    PUTBACK;
-	    perl_call_sv((SV*)cv, G_DISCARD);
+	    call_sv((SV*)cv, G_DISCARD);
 	}
     }
 
@@ -2656,6 +2820,38 @@ doeval(int gimme, OP** startop)
     RETURNOP(PL_eval_start);
 }
 
+STATIC PerlIO *
+S_doopen_pmc(pTHX_ const char *name, const char *mode)
+{
+    STRLEN namelen = strlen(name);
+    PerlIO *fp;
+
+    if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
+	SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
+	char *pmc = SvPV_nolen(pmcsv);
+	Stat_t pmstat;
+	Stat_t pmcstat;
+	if (PerlLIO_stat(pmc, &pmcstat) < 0) {
+	    fp = PerlIO_open(name, mode);
+	}
+	else {
+	    if (PerlLIO_stat(name, &pmstat) < 0 ||
+	        pmstat.st_mtime < pmcstat.st_mtime)
+	    {
+		fp = PerlIO_open(pmc, mode);
+	    }
+	    else {
+		fp = PerlIO_open(name, mode);
+	    }
+	}
+	SvREFCNT_dec(pmcsv);
+    }
+    else {
+	fp = PerlIO_open(name, mode);
+    }
+    return fp;
+}
+
 PP(pp_require)
 {
     djSP;
@@ -2668,18 +2864,18 @@ PP(pp_require)
     SV** svp;
     I32 gimme = G_SCALAR;
     PerlIO *tryrsfp = 0;
+    STRLEN n_a;
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
-	SET_NUMERIC_STANDARD();
-	if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
-	    DIE("Perl %s required--this is only version %s, stopped",
-		SvPV(sv,PL_na),PL_patchlevel);
+	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);
 	RETPUSHYES;
     }
     name = SvPV(sv, len);
     if (!(name && len > 0 && *name))
-	DIE("Null filename used");
+	DIE(aTHX_ "Null filename used");
     TAINT_PROPER("require");
     if (PL_op->op_type == OP_REQUIRE &&
       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
@@ -2705,7 +2901,7 @@ PP(pp_require)
     )
     {
 	tryname = name;
-	tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
+	tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
     }
     else {
 	AV *ar = GvAVn(PL_incgv);
@@ -2717,7 +2913,7 @@ PP(pp_require)
 	{
 	    namesv = NEWSV(806, 0);
 	    for (i = 0; i <= AvFILL(ar); i++) {
-		char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
+		char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
 #ifdef VMS
 		char *unixdir;
 		if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
@@ -2725,11 +2921,11 @@ PP(pp_require)
 		sv_setpv(namesv, unixdir);
 		sv_catpv(namesv, unixname);
 #else
-		sv_setpvf(namesv, "%s/%s", dir, name);
+		Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
 #endif
 		TAINT_PROPER("require");
 		tryname = SvPVX(namesv);
-		tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
+		tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
 		if (tryrsfp) {
 		    if (tryname[0] == '.' && tryname[1] == '/')
 			tryname += 2;
@@ -2743,23 +2939,28 @@ PP(pp_require)
     SvREFCNT_dec(namesv);
     if (!tryrsfp) {
 	if (PL_op->op_type == OP_REQUIRE) {
-	    SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
-	    SV *dirmsgsv = NEWSV(0, 0);
-	    AV *ar = GvAVn(PL_incgv);
-	    I32 i;
-	    if (instr(SvPVX(msg), ".h "))
-		sv_catpv(msg, " (change .h to .ph maybe?)");
-	    if (instr(SvPVX(msg), ".ph "))
-		sv_catpv(msg, " (did you run h2ph?)");
-	    sv_catpv(msg, " (@INC contains:");
-	    for (i = 0; i <= AvFILL(ar); i++) {
-		char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
-		sv_setpvf(dirmsgsv, " %s", dir);
-	        sv_catsv(msg, dirmsgsv);
+	    char *msgstr = name;
+	    if (namesv) {			/* did we lookup @INC? */
+		SV *msg = sv_2mortal(newSVpv(msgstr,0));
+		SV *dirmsgsv = NEWSV(0, 0);
+		AV *ar = GvAVn(PL_incgv);
+		I32 i;
+		sv_catpvn(msg, " in @INC", 8);
+		if (instr(SvPVX(msg), ".h "))
+		    sv_catpv(msg, " (change .h to .ph maybe?)");
+		if (instr(SvPVX(msg), ".ph "))
+		    sv_catpv(msg, " (did you run h2ph?)");
+		sv_catpv(msg, " (@INC contains:");
+		for (i = 0; i <= AvFILL(ar); i++) {
+		    char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
+		    Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
+		    sv_catsv(msg, dirmsgsv);
+		}
+		sv_catpvn(msg, ")", 1);
+		SvREFCNT_dec(dirmsgsv);
+		msgstr = SvPV_nolen(msg);
 	    }
-	    sv_catpvn(msg, ")", 1);
-    	    SvREFCNT_dec(dirmsgsv);
-	    DIE("%_", msg);
+	    DIE(aTHX_ "Can't locate %s", msgstr);
 	}
 
 	RETPUSHUNDEF;
@@ -2773,7 +2974,7 @@ PP(pp_require)
 
     ENTER;
     SAVETMPS;
-    lex_start(sv_2mortal(newSVpv("",0)));
+    lex_start(sv_2mortal(newSVpvn("",0)));
     SAVEGENERICSV(PL_rsfp_filters);
     PL_rsfp_filters = Nullav;
 
@@ -2783,9 +2984,13 @@ PP(pp_require)
     SAVEHINTS();
     PL_hints = 0;
     SAVEPPTR(PL_compiling.cop_warnings);
-    PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL 
-							     : WARN_NONE);
- 
+    if (PL_dowarn & G_WARN_ALL_ON)
+        PL_compiling.cop_warnings = WARN_ALL ;
+    else if (PL_dowarn & G_WARN_ALL_OFF)
+        PL_compiling.cop_warnings = WARN_NONE ;
+    else 
+        PL_compiling.cop_warnings = WARN_STD ;
+    
     /* switch to eval mode */
 
     push_return(PL_op->op_next);
@@ -2809,7 +3014,7 @@ PP(pp_require)
 
 PP(pp_dofile)
 {
-    return pp_require(ARGS);
+    return pp_require();
 }
 
 PP(pp_entereval)
@@ -2847,8 +3052,7 @@ PP(pp_entereval)
     SAVEHINTS();
     PL_hints = PL_op->op_targ;
     SAVEPPTR(PL_compiling.cop_warnings);
-    if (PL_compiling.cop_warnings != WARN_ALL 
-	&& PL_compiling.cop_warnings != WARN_NONE){
+    if (!specialWARN(PL_compiling.cop_warnings)) {
         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
         SAVEFREESV(PL_compiling.cop_warnings) ;
     }
@@ -2921,35 +3125,8 @@ PP(pp_leaveeval)
     }
     PL_curpm = newpm;	/* Don't pop $1 et al till now */
 
-    /*
-     * Closures mentioned at top level of eval cannot be referenced
-     * again, and their presence indirectly causes a memory leak.
-     * (Note that the fact that compcv and friends are still set here
-     * is, AFAIK, an accident.)  --Chip
-     */
-    if (AvFILLp(PL_comppad_name) >= 0) {
-	SV **svp = AvARRAY(PL_comppad_name);
-	I32 ix;
-	for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
-	    SV *sv = svp[ix];
-	    if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
-		SvREFCNT_dec(sv);
-		svp[ix] = &PL_sv_undef;
-
-		sv = PL_curpad[ix];
-		if (CvCLONE(sv)) {
-		    SvREFCNT_dec(CvOUTSIDE(sv));
-		    CvOUTSIDE(sv) = Nullcv;
-		}
-		else {
-		    SvREFCNT_dec(sv);
-		    sv = NEWSV(0,0);
-		    SvPADTMP_on(sv);
-		    PL_curpad[ix] = sv;
-		}
-	    }
-	}
-    }
+    if (AvFILLp(PL_comppad_name) >= 0)
+	free_closures();
 
 #ifdef DEBUGGING
     assert(CvDEPTH(PL_compcv) == 1);
@@ -2963,7 +3140,7 @@ PP(pp_leaveeval)
 	/* Unassume the success we assumed earlier. */
 	char *name = cx->blk_eval.old_name;
 	(void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
-	retop = die("%s did not return a true value", name);
+	retop = Perl_die(aTHX_ "%s did not return a true value", name);
 	/* die_where() did LEAVE, or we won't be here */
     }
     else {
@@ -2989,7 +3166,7 @@ PP(pp_entertry)
     PUSHEVAL(cx, 0, 0);
     PL_eval_root = PL_op;		/* Only needed so that goto works right. */
 
-    PL_in_eval = 1;
+    PL_in_eval = EVAL_INEVAL;
     sv_setpv(ERRSV,"");
     PUTBACK;
     return DOCATCH(PL_op->op_next);
@@ -3043,7 +3220,7 @@ PP(pp_leavetry)
 }
 
 STATIC void
-doparseform(SV *sv)
+S_doparseform(pTHX_ SV *sv)
 {
     STRLEN len;
     register char *s = SvPV_force(sv, len);
@@ -3060,7 +3237,7 @@ doparseform(SV *sv)
     bool ischop;
 
     if (len == 0)
-	croak("Null picture in formline");
+	Perl_croak(aTHX_ "Null picture in formline");
     
     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
     fpc = fops;
@@ -3331,7 +3508,7 @@ struct partition_stack_entry {
    ((this->*compare)(array[elt1], array[elt2]))
 #else
 #define qsort_cmp(elt1, elt2) \
-   ((*compare)(array[elt1], array[elt2]))
+   ((*compare)(aTHX_ array[elt1], array[elt2]))
 #endif
 
 #ifdef QSORT_ORDER_GUESS
@@ -3413,14 +3590,7 @@ doqsort_all_asserts(
 /* ****************************************************************** qsort */
 
 STATIC void
-#ifdef PERL_OBJECT
-qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
-#else
-qsortsv(
-   SV ** array,
-   size_t num_elts,
-   I32 (*compare)(SV *a, SV *b))
-#endif
+S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
 {
    register SV * temp;