X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a7cb1f9979dd83ab32266dc555f72f0939829c3f..ffb4440d02d1e8964757828cffb3de1e6f18ad0b:/pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index c028b4e..45f9a7e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -114,6 +114,8 @@ PP(pp_regcomp)
 		PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 
 	    pm->op_pmflags = pm->op_pmpermflags;	/* reset case sensitivity */
+	    if (DO_UTF8(tmpstr))
+		pm->op_pmdynflags |= PMdf_UTF8;
 	    pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
 	    PL_reginterp_cnt = 0;		/* XXXX Be extra paranoid - needed
 					   inside tie/overload accessors.  */
@@ -296,11 +298,17 @@ PP(pp_formline)
     NV value;
     bool gotsome;
     STRLEN len;
-    STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
+    STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
+    bool item_is_utf = FALSE;
 
     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
-	SvREADONLY_off(tmpForm);
-	doparseform(tmpForm);
+	if (SvREADONLY(tmpForm)) {
+	    SvREADONLY_off(tmpForm);
+	    doparseform(tmpForm);
+	    SvREADONLY_on(tmpForm);
+	}
+	else
+	    doparseform(tmpForm);
     }
 
     SvPV_force(PL_formtarget, len);
@@ -374,7 +382,7 @@ PP(pp_formline)
 	case FF_CHECKNL:
 	    item = s = SvPV(sv, len);
 	    itemsize = len;
-	    if (IN_UTF8) {
+	    if (DO_UTF8(sv)) {
 		itemsize = sv_len_utf8(sv);
 		if (itemsize != len) {
 		    I32 itembytes;
@@ -393,11 +401,13 @@ PP(pp_formline)
 			    break;
 			s++;
 		    }
+		    item_is_utf = TRUE;
 		    itemsize = s - item;
 		    sv_pos_b2u(sv, &itemsize);
 		    break;
 		}
 	    }
+	    item_is_utf = FALSE;
 	    if (itemsize > fieldsize)
 		itemsize = fieldsize;
 	    send = chophere = s + itemsize;
@@ -414,7 +424,7 @@ PP(pp_formline)
 	case FF_CHECKCHOP:
 	    item = s = SvPV(sv, len);
 	    itemsize = len;
-	    if (IN_UTF8) {
+	    if (DO_UTF8(sv)) {
 		itemsize = sv_len_utf8(sv);
 		if (itemsize != len) {
 		    I32 itembytes;
@@ -452,9 +462,11 @@ PP(pp_formline)
 			itemsize = chophere - item;
 			sv_pos_b2u(sv, &itemsize);
 		    }
+		    item_is_utf = TRUE;
 		    break;
 		}
 	    }
+	    item_is_utf = FALSE;
 	    if (itemsize <= fieldsize) {
 		send = chophere = s + itemsize;
 		while (s < send) {
@@ -510,7 +522,7 @@ PP(pp_formline)
 	case FF_ITEM:
 	    arg = itemsize;
 	    s = item;
-	    if (IN_UTF8) {
+	    if (item_is_utf) {
 		while (arg--) {
 		    if (*s & 0x80) {
 			switch (UTF8SKIP(s)) {
@@ -553,6 +565,7 @@ PP(pp_formline)
 	case FF_LINEGLOB:
 	    item = s = SvPV(sv, len);
 	    itemsize = len;
+	    item_is_utf = FALSE;		/* XXX is this correct? */
 	    if (itemsize) {
 		gotsome = TRUE;
 		send = s + itemsize;
@@ -585,7 +598,7 @@ PP(pp_formline)
 	    value = SvNV(sv);
 	    /* Formats aren't yet marked for locales, so assume "yes". */
 	    {
-		RESTORE_NUMERIC_LOCAL();
+		STORE_NUMERIC_STANDARD_SET_LOCAL();
 #if defined(USE_LONG_DOUBLE)
 		if (arg & 256) {
 		    sprintf(t, "%#*.*" PERL_PRIfldbl,
@@ -712,36 +725,60 @@ PP(pp_mapstart)
 PP(pp_mapwhile)
 {
     djSP;
-    I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
+    I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
     I32 count;
     I32 shift;
     SV** src;
     SV** dst; 
 
+    /* first, move source pointer to the next item in the source list */
     ++PL_markstack_ptr[-1];
-    if (diff) {
-	if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
-	    shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
-	    count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
+
+    /* if there are new items, push them into the destination list */
+    if (items) {
+	/* might need to make room back there first */
+	if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
+	    /* XXX this implementation is very pessimal because the stack
+	     * is repeatedly extended for every set of items.  Is possible
+	     * to do this without any stack extension or copying at all
+	     * by maintaining a separate list over which the map iterates
+	     * (like foreach does). --gsar */
+
+	    /* everything in the stack after the destination list moves
+	     * towards the end the stack by the amount of room needed */
+	    shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
+
+	    /* items to shift up (accounting for the moved source pointer) */
+	    count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
+
+	    /* This optimization is by Ben Tilly and it does
+	     * things differently from what Sarathy (gsar)
+	     * is describing.  The downside of this optimization is
+	     * that leaves "holes" (uninitialized and hopefully unused areas)
+	     * to the Perl stack, but on the other hand this
+	     * shouldn't be a problem.  If Sarathy's idea gets
+	     * implemented, this optimization should become
+	     * irrelevant.  --jhi */
+            if (shift < count)
+                shift = count; /* Avoid shifting too often --Ben Tilly */
 	    
 	    EXTEND(SP,shift);
 	    src = SP;
 	    dst = (SP += shift);
 	    PL_markstack_ptr[-1] += shift;
 	    *PL_markstack_ptr += shift;
-	    while (--count)
+	    while (count--)
 		*dst-- = *src--;
 	}
-	dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1; 
-	++diff;
-	while (--diff)
+	/* copy the new items down to the destination list */
+	dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 
+	while (items--)
 	    *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 
     }
     LEAVE;					/* exit inner scope */
 
     /* All done yet? */
     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
-	I32 items;
 	I32 gimme = GIMME_V;
 
 	(void)POPMARK;				/* pop top */
@@ -764,6 +801,7 @@ PP(pp_mapwhile)
 	ENTER;					/* enter inner scope */
 	SAVEVPTR(PL_curpm);
 
+	/* set $_ to the new source item */
 	src = PL_stack_base[PL_markstack_ptr[-1]];
 	SvTEMP_off(src);
 	DEFSV = src;
@@ -846,7 +884,7 @@ PP(pp_sort)
     up = myorigmark + 1;
     while (MARK < SP) {	/* This may or may not shift down one here. */
 	/*SUPPRESS 560*/
-	if (*up = *++MARK) {			/* Weed out nulls. */
+	if ((*up = *++MARK)) {			/* Weed out nulls. */
 	    SvTEMP_off(*up);
 	    if (!PL_sortcop && !SvPOK(*up)) {
 		STRLEN n_a;
@@ -870,15 +908,22 @@ PP(pp_sort)
 
 	    CATCH_SET(TRUE);
 	    PUSHSTACKi(PERLSI_SORT);
-	    if (PL_sortstash != stash) {
-		PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
-		PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
-		PL_sortstash = stash;
+	    if (!hasargs && !is_xsub) {
+		if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
+		    SAVESPTR(PL_firstgv);
+		    SAVESPTR(PL_secondgv);
+		    PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
+		    PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
+		    PL_sortstash = stash;
+		}
+#ifdef USE_THREADS
+		sv_lock((SV *)PL_firstgv);
+		sv_lock((SV *)PL_secondgv);
+#endif
+		SAVESPTR(GvSV(PL_firstgv));
+		SAVESPTR(GvSV(PL_secondgv));
 	    }
 
-	    SAVESPTR(GvSV(PL_firstgv));
-	    SAVESPTR(GvSV(PL_secondgv));
-
 	    PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
 	    if (!(PL_op->op_flags & OPf_SPECIAL)) {
 		cx->cx_type = CXt_SUB;
@@ -897,6 +942,7 @@ PP(pp_sort)
 		cx->blk_sub.savearray = GvAV(PL_defgv);
 		GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
 #endif /* USE_THREADS */
+		cx->blk_sub.oldcurpad = PL_curpad;
 		cx->blk_sub.argarray = av;
 	    }
 	    qsortsv((myorigmark+1), max,
@@ -997,7 +1043,9 @@ PP(pp_flop)
 	    mg_get(right);
 
 	if (SvNIOKp(left) || !SvPOKp(left) ||
-	  (looks_like_number(left) && *SvPVX(left) != '0') )
+	    SvNIOKp(right) || !SvPOKp(right) ||
+	    (looks_like_number(left) && *SvPVX(left) != '0' &&
+	     looks_like_number(right) && *SvPVX(right) != '0'))
 	{
 	    if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
 		DIE(aTHX_ "Range iterator outside integer range");
@@ -1060,28 +1108,28 @@ S_dopoptolabel(pTHX_ char *label)
 	cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_FORMAT:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
 			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
@@ -1186,28 +1234,28 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 	cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_FORMAT:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
 			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
@@ -1223,7 +1271,6 @@ Perl_dounwind(pTHX_ I32 cxix)
 {
     dTHR;
     register PERL_CONTEXT *cx;
-    SV **newsp;
     I32 optype;
 
     while (cxstack_ix > cxix) {
@@ -1300,14 +1347,13 @@ Perl_qerror(pTHX_ SV *err)
     else if (PL_errors)
 	sv_catsv(PL_errors, err);
     else
-	Perl_warn(aTHX_ "%_", err);
+	Perl_warn(aTHX_ "%"SVf, err);
     ++PL_error_count;
 }
 
 OP *
 Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
-    dSP;
     STRLEN n_a;
     if (PL_in_eval) {
 	I32 cxix;
@@ -1332,9 +1378,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 		    SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
 		    sv_catpvn(err, prefix, sizeof(prefix)-1);
 		    sv_catpvn(err, message, msglen);
-		    if (ckWARN(WARN_UNSAFE)) {
+		    if (ckWARN(WARN_MISC)) {
 			STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
-			Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
+			Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
 		    }
 		}
 	    }
@@ -1441,7 +1487,7 @@ PP(pp_caller)
 
     if (MAXARG)
 	count = POPi;
-    EXTEND(SP, 7);
+    EXTEND(SP, 10);
     for (;;) {
 	/* we may be in a higher stacklevel, so dig down deeper */
 	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -1508,15 +1554,21 @@ PP(pp_caller)
     else
 	PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
     if (CxTYPE(cx) == CXt_EVAL) {
+	/* eval STRING */
 	if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
 	    PUSHs(cx->blk_eval.cur_text);
 	    PUSHs(&PL_sv_no);
-	} 
-	else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
-	    /* Require, put the name. */
-	    PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
+	}
+	/* require */
+	else if (cx->blk_eval.old_namesv) {
+	    PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
 	    PUSHs(&PL_sv_yes);
 	}
+	/* eval BLOCK (try blocks have old_namesv == 0) */
+	else {
+	    PUSHs(&PL_sv_undef);
+	    PUSHs(&PL_sv_undef);
+	}
     }
     else {
 	PUSHs(&PL_sv_undef);
@@ -1533,7 +1585,7 @@ PP(pp_caller)
 	    PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
 				SVt_PVAV)));
 	    GvMULTI_on(tmpgv);
-	    AvREAL_off(PL_dbargs);		/* XXX Should be REIFY */
+	    AvREAL_off(PL_dbargs);	/* XXX should be REIFY (see av.h) */
 	}
 
 	if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
@@ -1546,6 +1598,20 @@ PP(pp_caller)
      * use the global PL_hints) */
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
 			     HINT_PRIVATE_MASK)));
+    {
+	SV * mask ;
+	SV * old_warnings = cx->blk_oldcop->cop_warnings ;
+
+	if  (old_warnings == pWARN_NONE || 
+		(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
+            mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+        else if (old_warnings == pWARN_ALL || 
+		  (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
+            mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+        else
+            mask = newSVsv(old_warnings);
+        PUSHs(sv_2mortal(mask));
+    }
     RETURN;
 }
 
@@ -1674,7 +1740,11 @@ PP(pp_enteriter)
 	if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
 	    dPOPss;
 	    if (SvNIOKp(sv) || !SvPOKp(sv) ||
-		(looks_like_number(sv) && *SvPVX(sv) != '0')) {
+		SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
+		(looks_like_number(sv) && *SvPVX(sv) != '0' &&
+		 looks_like_number((SV*)cx->blk_loop.iterary) &&
+		 *SvPVX(cx->blk_loop.iterary) != '0'))
+	    {
 		 if (SvNV(sv) < IV_MIN ||
 		     SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
 		     DIE(aTHX_ "Range iterator outside integer range");
@@ -1756,6 +1826,7 @@ PP(pp_return)
     I32 cxix;
     register PERL_CONTEXT *cx;
     bool popsub2 = FALSE;
+    bool clear_errsv = FALSE;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -1786,7 +1857,11 @@ PP(pp_return)
 	popsub2 = TRUE;
 	break;
     case CXt_EVAL:
+	if (!(PL_in_eval & EVAL_KEEPERR))
+	    clear_errsv = TRUE;
 	POPEVAL(cx);
+	if (CxTRYBLOCK(cx))
+	    break;
 	if (AvFILLp(PL_comppad_name) >= 0)
 	    free_closures();
 	lex_end();
@@ -1794,9 +1869,9 @@ PP(pp_return)
 	    (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(aTHX_ "%s did not return a true value", name);
+	    SV *nsv = cx->blk_eval.old_namesv;
+	    (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
+	    DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
 	}
 	break;
     case CXt_FORMAT:
@@ -1815,15 +1890,21 @@ PP(pp_return)
 			*++newsp = SvREFCNT_inc(*SP);
 			FREETMPS;
 			sv_2mortal(*newsp);
-		    } else {
+		    }
+		    else {
+			sv = SvREFCNT_inc(*SP);	/* FREETMPS could clobber it */
 			FREETMPS;
-			*++newsp = sv_mortalcopy(*SP);
+			*++newsp = sv_mortalcopy(sv);
+			SvREFCNT_dec(sv);
 		    }
-		} else
+		}
+		else
 		    *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
-	    } else
+	    }
+	    else
 		*++newsp = sv_mortalcopy(*SP);
-	} else
+	}
+	else
 	    *++newsp = &PL_sv_undef;
     }
     else if (gimme == G_ARRAY) {
@@ -1845,6 +1926,8 @@ PP(pp_return)
 
     LEAVE;
     LEAVESUB(sv);
+    if (clear_errsv)
+	sv_setpv(ERRSV,"");
     return pop_return();
 }
 
@@ -1938,7 +2021,7 @@ PP(pp_next)
 {
     I32 cxix;
     register PERL_CONTEXT *cx;
-    I32 oldsave;
+    I32 inner;
 
     if (PL_op->op_flags & OPf_SPECIAL) {
 	cxix = dopoptoloop(cxstack_ix);
@@ -1953,9 +2036,12 @@ PP(pp_next)
     if (cxix < cxstack_ix)
 	dounwind(cxix);
 
+    /* clear off anything above the scope we're re-entering, but
+     * save the rest until after a possible continue block */
+    inner = PL_scopestack_ix;
     TOPBLOCK(cx);
-    oldsave = PL_scopestack[PL_scopestack_ix - 1];
-    LEAVE_SCOPE(oldsave);
+    if (PL_scopestack_ix < inner)
+	leave_scope(PL_scopestack[PL_scopestack_ix]);
     return cx->blk_loop.next_op;
 }
 
@@ -2019,7 +2105,7 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
 		 (ops[-1]->op_type != OP_NEXTSTATE &&
 		  ops[-1]->op_type != OP_DBSTATE)))
 		*ops++ = kid;
-	    if (o = dofindlabel(kid, label, ops, oplimit))
+	    if ((o = dofindlabel(kid, label, ops, oplimit)))
 		return o;
 	}
     }
@@ -2113,7 +2199,6 @@ PP(pp_goto)
 	    }
 	    else if (CvXSUB(cv)) {	/* put GvAV(defgv) back onto stack */
 		AV* av;
-		int i;
 #ifdef USE_THREADS
 		av = (AV*)PL_curpad[0];
 #else
@@ -2253,6 +2338,7 @@ PP(pp_goto)
 		    cx->blk_sub.savearray = GvAV(PL_defgv);
 		    GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
 #endif /* USE_THREADS */
+		    cx->blk_sub.oldcurpad = PL_curpad;
 		    cx->blk_sub.argarray = av;
 		    ++mark;
 
@@ -2354,10 +2440,12 @@ PP(pp_goto)
 		gotoprobe = PL_main_root;
 		break;
 	    }
-	    retop = dofindlabel(gotoprobe, label,
-				enterops, enterops + GOTO_DEPTH);
-	    if (retop)
-		break;
+	    if (gotoprobe) {
+		retop = dofindlabel(gotoprobe, label,
+				    enterops, enterops + GOTO_DEPTH);
+		if (retop)
+		    break;
+	    }
 	    PL_lastgotoprobe = gotoprobe;
 	}
 	if (!retop)
@@ -2385,8 +2473,7 @@ 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(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
-			label);
+		    DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
 		CALL_FPTR(PL_op->op_ppaddr)(aTHX);
 	    }
 	    PL_op = oldop;
@@ -2418,8 +2505,8 @@ PP(pp_exit)
 	anum = 0;
     else {
 	anum = SvIVx(POPs);
-#ifdef VMSISH_EXIT
-	if (anum == 1 && VMSISH_EXIT)
+#ifdef VMS
+        if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
 	    anum = 0;
 #endif
     }
@@ -2496,9 +2583,17 @@ S_save_lines(pTHX_ AV *array, SV *sv)
     }
 }
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
 STATIC void *
 S_docatch_body(pTHX_ va_list args)
 {
+    return docatch_body();
+}
+#endif
+
+STATIC void *
+S_docatch_body(pTHX)
+{
     CALLRUNOPS(aTHX);
     return NULL;
 }
@@ -2516,10 +2611,18 @@ S_docatch(pTHX_ OP *o)
     assert(CATCH_GET == TRUE);
 #endif
     PL_op = o;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
  redo_body:
     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
+#else
+    JMPENV_PUSH(ret);
+#endif
     switch (ret) {
     case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+	docatch_body();
+#endif
 	break;
     case 3:
 	if (PL_restartop && cursi == PL_curstackinfo) {
@@ -2529,10 +2632,12 @@ S_docatch(pTHX_ OP *o)
 	}
 	/* FALL THROUGH */
     default:
+	JMPENV_POP;
 	PL_op = oldop;
 	JMPENV_JUMP(ret);
 	/* NOTREACHED */
     }
+    JMPENV_POP;
     PL_op = oldop;
     return Nullop;
 }
@@ -2549,8 +2654,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
     I32 optype;
     OP dummy;
-    OP *oop = PL_op, *rop;
-    char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
+    OP *rop;
+    char tbuf[TYPE_DIGITS(long) + 12 + 10];
+    char *tmpbuf = tbuf;
     char *safestr;
 
     ENTER;
@@ -2559,13 +2665,21 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     /* switch to eval mode */
 
     if (PL_curcop == &PL_compiling) {
-	SAVECOPSTASH(&PL_compiling);
+	SAVECOPSTASH_FREE(&PL_compiling);
 	CopSTASH_set(&PL_compiling, PL_curstash);
     }
-    SAVECOPFILE(&PL_compiling);
-    SAVECOPLINE(&PL_compiling);
-    sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
+    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
+	SV *sv = sv_newmortal();
+	Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
+		       code, (unsigned long)++PL_evalseq,
+		       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+	tmpbuf = SvPVX(sv);
+    }
+    else
+	sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
+    SAVECOPFILE_FREE(&PL_compiling);
     CopFILE_set(&PL_compiling, tmpbuf+2);
+    SAVECOPLINE(&PL_compiling);
     CopLINE_set(&PL_compiling, 1);
     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
        deleting the eval's FILEGV from the stash before gv_check() runs
@@ -2668,8 +2782,11 @@ S_doeval(pTHX_ int gimme, OP** startop)
     av_store(comppadlist, 1, (SV*)PL_comppad);
     CvPADLIST(PL_compcv) = comppadlist;
 
-    if (!saveop || saveop->op_type != OP_REQUIRE)
+    if (!saveop ||
+	(saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
+    {
 	CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
+    }
 
     SAVEFREESV(PL_compcv);
 
@@ -2682,6 +2799,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
     SAVESPTR(PL_beginav);
     PL_beginav = newAV();
     SAVEFREESV(PL_beginav);
+    SAVEI32(PL_error_count);
 
     /* try to compile it */
 
@@ -2835,8 +2953,8 @@ PP(pp_require)
 
     sv = POPs;
     if (SvNIOKp(sv)) {
-	UV rev, ver, sver;
-	if (SvPOKp(sv) && SvUTF8(sv)) {		/* require v5.6.1 */
+	if (SvPOK(sv) && SvNOK(sv)) {		/* require v5.6.1 */
+	    UV rev = 0, ver = 0, sver = 0;
 	    I32 len;
 	    U8 *s = (U8*)SvPVX(sv);
 	    U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
@@ -2848,41 +2966,49 @@ PP(pp_require)
 		    s += len;
 		    if (s < end)
 			sver = utf8_to_uv(s, &len);
-		    else
-			sver = 0;
 		}
-		else
-		    ver = 0;
 	    }
-	    else
-		rev = 0;
 	    if (PERL_REVISION < rev
 		|| (PERL_REVISION == rev
 		    && (PERL_VERSION < ver
 			|| (PERL_VERSION == ver
 			    && PERL_SUBVERSION < sver))))
 	    {
-		DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
-		    "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
+		DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
+		    "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
 		    PERL_VERSION, PERL_SUBVERSION);
 	    }
+	    RETPUSHYES;
 	}
 	else if (!SvPOKp(sv)) {			/* require 5.005_03 */
-	    NV n = SvNV(sv);
-	    rev = (UV)n;
-	    ver = (UV)((n-rev)*1000);
-	    sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
-
 	    if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
 		+ ((NV)PERL_SUBVERSION/(NV)1000000)
 		+ 0.00000099 < SvNV(sv))
 	    {
-		DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
-		    "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
-		    PERL_VERSION, PERL_SUBVERSION);
+		NV nrev = SvNV(sv);
+		UV rev = (UV)nrev;
+		NV nver = (nrev - rev) * 1000;
+		UV ver = (UV)(nver + 0.0009);
+		NV nsver = (nver - ver) * 1000;
+		UV sver = (UV)(nsver + 0.0009);
+
+		/* help out with the "use 5.6" confusion */
+		if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
+		    DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
+			"this is only v%d.%d.%d, stopped"
+			" (did you mean v%"UVuf".%"UVuf".0?)",
+			rev, ver, sver, PERL_REVISION, PERL_VERSION,
+			PERL_SUBVERSION, rev, ver/100);
+		}
+		else {
+		    DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
+			"this is only v%d.%d.%d, stopped",
+			rev, ver, sver, PERL_REVISION, PERL_VERSION,
+			PERL_SUBVERSION);
+		}
 	    }
+	    RETPUSHYES;
 	}
-	RETPUSHYES;
     }
     name = SvPV(sv, len);
     if (!(name && len > 0 && *name))
@@ -2901,8 +3027,19 @@ PP(pp_require)
     {
 	tryname = name;
 	tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
+#ifdef MACOS_TRADITIONAL
+	/* We consider paths of the form :a:b ambiguous and interpret them first
+	   as global then as local
+	*/
+    	if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
+	    goto trylocal;
+    }
+    else 
+trylocal: {
+#else
     }
     else {
+#endif
 	AV *ar = GvAVn(PL_incgv);
 	I32 i;
 #ifdef VMS
@@ -2956,7 +3093,7 @@ PP(pp_require)
 
 			    if (io) {
 				tryrsfp = IoIFP(io);
-				if (IoTYPE(io) == '|') {
+				if (IoTYPE(io) == IoTYPE_PIPE) {
 				    /* reading from a child process doesn't
 				       nest -- when returning from reading
 				       the inner module, the outer one is
@@ -3020,6 +3157,10 @@ PP(pp_require)
 		}
 		else {
 		    char *dir = SvPVx(dirsv, n_a);
+#ifdef MACOS_TRADITIONAL
+		    char buf[256];
+		    Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
+#else
 #ifdef VMS
 		    char *unixdir;
 		    if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
@@ -3029,8 +3170,17 @@ PP(pp_require)
 #else
 		    Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
 #endif
+#endif
 		    TAINT_PROPER("require");
 		    tryname = SvPVX(namesv);
+#ifdef MACOS_TRADITIONAL
+		    {
+		    	/* Convert slashes in the name part, but not the directory part, to colons */
+		    	char * colon;
+		    	for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
+			    *colon++ = ':';
+		    }
+#endif
 		    tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
 		    if (tryrsfp) {
 			if (tryname[0] == '.' && tryname[1] == '/')
@@ -3041,7 +3191,7 @@ PP(pp_require)
 	    }
 	}
     }
-    SAVECOPFILE(&PL_compiling);
+    SAVECOPFILE_FREE(&PL_compiling);
     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
     SvREFCNT_dec(namesv);
     if (!tryrsfp) {
@@ -3090,11 +3240,11 @@ PP(pp_require)
     PL_hints = 0;
     SAVESPTR(PL_compiling.cop_warnings);
     if (PL_dowarn & G_WARN_ALL_ON)
-        PL_compiling.cop_warnings = WARN_ALL ;
+        PL_compiling.cop_warnings = pWARN_ALL ;
     else if (PL_dowarn & G_WARN_ALL_OFF)
-        PL_compiling.cop_warnings = WARN_NONE ;
+        PL_compiling.cop_warnings = pWARN_NONE ;
     else 
-        PL_compiling.cop_warnings = WARN_STD ;
+        PL_compiling.cop_warnings = pWARN_STD ;
 
     if (filter_sub || filter_child_proc) {
 	SV *datasv = filter_add(run_user_filter, Nullsv);
@@ -3135,7 +3285,8 @@ PP(pp_entereval)
     register PERL_CONTEXT *cx;
     dPOPss;
     I32 gimme = GIMME_V, was = PL_sub_generation;
-    char tmpbuf[TYPE_DIGITS(long) + 12];
+    char tbuf[TYPE_DIGITS(long) + 12];
+    char *tmpbuf = tbuf;
     char *safestr;
     STRLEN len;
     OP *ret;
@@ -3150,9 +3301,18 @@ PP(pp_entereval)
  
     /* switch to eval mode */
 
-    SAVECOPFILE(&PL_compiling);
-    sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
+	SV *sv = sv_newmortal();
+	Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
+		       (unsigned long)++PL_evalseq,
+		       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+	tmpbuf = SvPVX(sv);
+    }
+    else
+	sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+    SAVECOPFILE_FREE(&PL_compiling);
     CopFILE_set(&PL_compiling, tmpbuf+2);
+    SAVECOPLINE(&PL_compiling);
     CopLINE_set(&PL_compiling, 1);
     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
        deleting the eval's FILEGV from the stash before gv_check() runs
@@ -3164,9 +3324,11 @@ PP(pp_entereval)
     SAVEHINTS();
     PL_hints = PL_op->op_targ;
     SAVESPTR(PL_compiling.cop_warnings);
-    if (!specialWARN(PL_compiling.cop_warnings)) {
-        PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
-        SAVEFREESV(PL_compiling.cop_warnings) ;
+    if (specialWARN(PL_curcop->cop_warnings))
+        PL_compiling.cop_warnings = PL_curcop->cop_warnings;
+    else {
+        PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
+        SAVEFREESV(PL_compiling.cop_warnings);
     }
 
     push_return(PL_op->op_next);
@@ -3251,9 +3413,9 @@ PP(pp_leaveeval)
 	!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
     {
 	/* 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 = Perl_die(aTHX_ "%s did not return a true value", name);
+	SV *nsv = cx->blk_eval.old_namesv;
+	(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
+	retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
 	/* die_where() did LEAVE, or we won't be here */
     }
     else {
@@ -3275,7 +3437,7 @@ PP(pp_entertry)
     SAVETMPS;
 
     push_return(cLOGOP->op_other->op_next);
-    PUSHBLOCK(cx, CXt_EVAL, SP);
+    PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
     PUSHEVAL(cx, 0, 0);
     PL_eval_root = PL_op;		/* Only needed so that goto works right. */
 
@@ -3926,7 +4088,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
                on the correct side of the partition. If I find a greater
                value, then stop the scan.
             */
-            while (still_work_on_left = (u_right >= part_left)) {
+            while ((still_work_on_left = (u_right >= part_left))) {
                s = qsort_cmp(u_right, pc_left);
                if (s < 0) {
                   --u_right;
@@ -3947,7 +4109,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
 
             /* Do a mirror image scan of uncompared values on the right
             */
-            while (still_work_on_right = (u_left <= part_right)) {
+            while ((still_work_on_right = (u_left <= part_right))) {
                s = qsort_cmp(pc_right, u_left);
                if (s < 0) {
                   ++u_left;