X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=fce163fc3e9538e06f15dd2f876087146a2be80e;hb=80f367555cea890216d3e46c721ae1841e0e0c4f;hp=81b42812788b7aa2529fa2866f3597b3764d9d69;hpb=045c1f128ac729dc76c4da7e8ffe34bf12692b94;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 81b4281..fce163f 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-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.
@@ -17,6 +17,7 @@
  */
 
 #include "EXTERN.h"
+#define PERL_IN_PP_CTL_C
 #include "perl.h"
 
 #ifndef WORD_ALIGN
@@ -25,22 +26,23 @@
 
 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
 
+static I32 sortcv(pTHXo_ SV *a, SV *b);
+static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
+static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
+static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
+static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
+static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
+static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
+static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
+static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
+static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
+
 #ifdef PERL_OBJECT
-#define CALLOP this->*op
+static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
+static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
 #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));
+#define sv_cmp_static Perl_sv_cmp
+#define sv_cmp_locale_static Perl_sv_cmp_locale
 #endif
 
 PP(pp_wantarray)
@@ -112,7 +114,9 @@ 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);
+	    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.  */
 	}
@@ -132,9 +136,13 @@ PP(pp_regcomp)
     else if (strEQ("\\s+", pm->op_pmregexp->precomp))
 	pm->op_pmflags |= PMf_WHITE;
 
+    /* XXX runtime compiled output needs to move to the pad */
     if (pm->op_pmflags & PMf_KEEP) {
 	pm->op_private &= ~OPpRUNTIME;	/* no point compiling again */
+#if !defined(USE_ITHREADS) && !defined(USE_THREADS)
+	/* XXX can't change the optree at runtime either */
 	cLOGOP->op_first->op_next = PL_op->op_next;
+#endif
     }
     RETURN;
 }
@@ -154,16 +162,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,
-				     s == m, Nullsv, NULL,
-				     cx->sb_safebase ? 0 : REXEC_COPY_STR))
+	if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
+				     s == m, cx->sb_targ, NULL,
+				     ((cx->sb_rflags & 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);
@@ -191,23 +201,38 @@ 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;
+    { /* Update the pos() information. */
+	SV *sv = cx->sb_targ;
+	MAGIC *mg;
+	I32 i;
+	if (SvTYPE(sv) < SVt_PVMG)
+	    SvUPGRADE(sv, SVt_PVMG);
+	if (!(mg = mg_find(sv, 'g'))) {
+	    sv_magic(sv, Nullsv, 'g', Nullch, 0);
+	    mg = mg_find(sv, 'g');
+	}
+	i = m - orig;
+	if (DO_UTF8(sv))
+	    sv_pos_b2u(sv, &i);
+	mg->mg_len = i;
+    }
     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;
@@ -221,13 +246,13 @@ rxres_save(void **rsp, REGEXP *rx)
 	*rsp = (void*)p;
     }
 
-    *p++ = (UV)rx->subbase;
-    rx->subbase = Nullch;
+    *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
+    RX_MATCH_COPIED_off(rx);
 
     *p++ = rx->nparens;
 
-    *p++ = (UV)rx->subbeg;
-    *p++ = (UV)rx->subend;
+    *p++ = PTR2UV(rx->subbeg);
+    *p++ = (UV)rx->sublen;
     for (i = 0; i <= rx->nparens; ++i) {
 	*p++ = (UV)rx->startp[i];
 	*p++ = (UV)rx->endp[i];
@@ -235,32 +260,33 @@ 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->subbeg = INT2PTR(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;
 
     if (p) {
-	Safefree((char*)(*p));
+	Safefree(INT2PTR(char*,*p));
 	Safefree(p);
 	*rsp = Null(void*);
     }
@@ -284,17 +310,24 @@ 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_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);
-    t = SvGROW(PL_formtarget, len + SvCUR(tmpForm) + 1);  /* XXX SvCUR bad */
+    t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
     t += len;
     f = SvPV(tmpForm, len);
     /* need to jump to the next word */
@@ -324,11 +357,12 @@ PP(pp_formline)
 	    case FF_MORE:	name = "MORE";		break;
 	    case FF_LINEMARK:	name = "LINEMARK";	break;
 	    case FF_END:	name = "END";		break;
+            case FF_0DECIMAL:	name = "0DECIMAL";	break;
 	    }
 	    if (arg >= 0)
-		PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
+		PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 	    else
-		PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
+		PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 	} )
 	switch (*fpc++) {
 	case FF_LINEMARK:
@@ -356,14 +390,40 @@ PP(pp_formline)
 		sv = *++MARK;
 	    else {
 		sv = &PL_sv_no;
-		if (PL_dowarn)
-		    warn("Not enough format arguments");
+		if (ckWARN(WARN_SYNTAX))
+		    Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
 	    }
 	    break;
 
 	case FF_CHECKNL:
 	    item = s = SvPV(sv, len);
 	    itemsize = len;
+	    if (DO_UTF8(sv)) {
+		itemsize = sv_len_utf8(sv);
+		if (itemsize != len) {
+		    I32 itembytes;
+		    if (itemsize > fieldsize) {
+			itemsize = fieldsize;
+			itembytes = itemsize;
+			sv_pos_u2b(sv, &itembytes, 0);
+		    }
+		    else
+			itembytes = len;
+		    send = chophere = s + itembytes;
+		    while (s < send) {
+			if (*s & ~31)
+			    gotsome = TRUE;
+			else if (*s == '\n')
+			    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;
@@ -380,6 +440,49 @@ PP(pp_formline)
 	case FF_CHECKCHOP:
 	    item = s = SvPV(sv, len);
 	    itemsize = len;
+	    if (DO_UTF8(sv)) {
+		itemsize = sv_len_utf8(sv);
+		if (itemsize != len) {
+		    I32 itembytes;
+		    if (itemsize <= fieldsize) {
+			send = chophere = s + itemsize;
+			while (s < send) {
+			    if (*s == '\r') {
+				itemsize = s - item;
+				break;
+			    }
+			    if (*s++ & ~31)
+				gotsome = TRUE;
+			}
+		    }
+		    else {
+			itemsize = fieldsize;
+			itembytes = itemsize;
+			sv_pos_u2b(sv, &itembytes, 0);
+			send = chophere = s + itembytes;
+			while (s < send || (s == send && isSPACE(*s))) {
+			    if (isSPACE(*s)) {
+				if (chopspace)
+				    chophere = s;
+				if (*s == '\r')
+				    break;
+			    }
+			    else {
+				if (*s & ~31)
+				    gotsome = TRUE;
+				if (strchr(PL_chopset, *s))
+				    chophere = s + 1;
+			    }
+			    s++;
+			}
+			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) {
@@ -435,16 +538,34 @@ PP(pp_formline)
 	case FF_ITEM:
 	    arg = itemsize;
 	    s = item;
+	    if (item_is_utf) {
+		while (arg--) {
+		    if (*s & 0x80) {
+			switch (UTF8SKIP(s)) {
+			case 7: *t++ = *s++;
+			case 6: *t++ = *s++;
+			case 5: *t++ = *s++;
+			case 4: *t++ = *s++;
+			case 3: *t++ = *s++;
+			case 2: *t++ = *s++;
+			case 1: *t++ = *s++;
+			}
+		    }
+		    else {
+			if ( !((*t++ = *s++) & ~31) )
+			    t[-1] = ' ';
+		    }
+		}
+		break;
+	    }
 	    while (arg--) {
-#if 'z' - 'a' != 25
+#ifdef EBCDIC
 		int ch = *t++ = *s++;
-		if (!iscntrl(ch))
-		    t[-1] = ' ';
+		if (iscntrl(ch))
 #else
 		if ( !((*t++ = *s++) & ~31) )
-		    t[-1] = ' ';
 #endif
-
+		    t[-1] = ' ';
 	    }
 	    break;
 
@@ -460,6 +581,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;
@@ -473,7 +595,7 @@ PP(pp_formline)
 		}
 		SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 		sv_catpvn(PL_formtarget, item, itemsize);
-		SvGROW(PL_formtarget, SvCUR(PL_formtarget) + SvCUR(tmpForm) + 1);
+		SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 		t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 	    }
 	    break;
@@ -491,15 +613,66 @@ 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);
+	    {
+		STORE_NUMERIC_STANDARD_SET_LOCAL();
+#if defined(USE_LONG_DOUBLE)
+		if (arg & 256) {
+		    sprintf(t, "%#*.*" PERL_PRIfldbl,
+			    (int) fieldsize, (int) arg & 255, value);
+		} else {
+		    sprintf(t, "%*.0" PERL_PRIfldbl, (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;
 
+	case FF_0DECIMAL:
+	    /* If the field is marked with ^ and the value is undefined,
+	       blank it out. */
+	    arg = *fpc++;
+	    if ((arg & 512) && !SvOK(sv)) {
+		arg = fieldsize;
+		while (arg--)
+		    *t++ = ' ';
+		break;
+	    }
+	    gotsome = TRUE;
+	    value = SvNV(sv);
+	    /* Formats aren't yet marked for locales, so assume "yes". */
+	    {
+		STORE_NUMERIC_STANDARD_SET_LOCAL();
+#if defined(USE_LONG_DOUBLE)
+		if (arg & 256) {
+		    sprintf(t, "%#0*.*" PERL_PRIfldbl,
+			    (int) fieldsize, (int) arg & 255, value); 
+/* is this legal? I don't have long doubles */      
+		} else {
+		    sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
+		}
+#else
+		if (arg & 256) {
+		    sprintf(t, "%#0*.*f",
+			    (int) fieldsize, (int) arg & 255, value);
+		} else {
+		    sprintf(t, "%0*.0f",
+			    (int) fieldsize, value);
+		}
+#endif
+		RESTORE_NUMERIC_STANDARD();
+	    }
+	    t += fieldsize;
+	    break;
+	    
 	case FF_NEWLINE:
 	    f++;
 	    while (t-- > linemark && *t == ' ') ;
@@ -517,7 +690,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;
@@ -531,7 +704,13 @@ PP(pp_formline)
 	    break;
 
 	case FF_MORE:
-	    if (itemsize) {
+	    s = chophere;
+	    send = item + len;
+	    if (chopspace) {
+		while (*s && isSPACE(*s) && s < send)
+		    s++;
+	    }
+	    if (s < send) {
 		arg = fieldsize - itemsize;
 		if (arg) {
 		    fieldsize -= arg;
@@ -567,23 +746,19 @@ 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;
-#ifdef USE_THREADS
-    /* SAVE_DEFSV does *not* suffice here */
-    save_sptr(&THREADSV(0));
-#else
-    SAVESPTR(GvSV(PL_defgv));
-#endif /* USE_THREADS */
+    /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
+    SAVESPTR(DEFSV);
     ENTER;					/* enter inner scope */
-    SAVESPTR(PL_curpm);
+    SAVEVPTR(PL_curpm);
 
     src = PL_stack_base[*PL_markstack_ptr];
     SvTEMP_off(src);
@@ -591,48 +766,72 @@ 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)
 {
     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 */
@@ -653,8 +852,9 @@ PP(pp_mapwhile)
 	SV *src;
 
 	ENTER;					/* enter inner scope */
-	SAVESPTR(PL_curpm);
+	SAVEVPTR(PL_curpm);
 
+	/* set $_ to the new source item */
 	src = PL_stack_base[PL_markstack_ptr[-1]];
 	SvTEMP_off(src);
 	DEFSV = src;
@@ -674,6 +874,9 @@ PP(pp_sort)
     CV *cv;
     I32 gimme = GIMME;
     OP* nextop = PL_op->op_next;
+    I32 overloading = 0;
+    bool hasargs = FALSE;
+    I32 is_xsub = 0;
 
     if (gimme != G_ARRAY) {
 	SP = MARK;
@@ -681,53 +884,68 @@ PP(pp_sort)
     }
 
     ENTER;
-    SAVEPPTR(PL_sortcop);
+    SAVEVPTR(PL_sortcop);
     if (PL_op->op_flags & OPf_STACKED) {
 	if (PL_op->op_flags & OPf_SPECIAL) {
 	    OP *kid = cLISTOP->op_first->op_sibling;	/* pass pushmark */
 	    kid = kUNOP->op_first;			/* pass rv2gv */
 	    kid = kUNOP->op_first;			/* pass leave */
 	    PL_sortcop = kid->op_next;
-	    stash = PL_curcop->cop_stash;
+	    stash = CopSTASH(PL_curcop);
 	}
 	else {
 	    cv = sv_2cv(*++MARK, &stash, &gv, 0);
+	    if (cv && SvPOK(cv)) {
+		STRLEN n_a;
+		char *proto = SvPV((SV*)cv, n_a);
+		if (proto && strEQ(proto, "$$")) {
+		    hasargs = TRUE;
+		}
+	    }
 	    if (!(cv && CvROOT(cv))) {
-		if (gv) {
+		if (cv && CvXSUB(cv)) {
+		    is_xsub = 1;
+		}
+		else if (gv) {
 		    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_ "Undefined sort subroutine \"%s\" called",
 			SvPVX(tmpstr));
 		}
-		if (cv) {
-		    if (CvXSUB(cv))
-			DIE("Xsub called in sort");
-		    DIE("Undefined subroutine in sort");
+		else {
+		    DIE(aTHX_ "Undefined subroutine in sort");
 		}
-		DIE("Not a CODE reference in sort");
 	    }
-	    PL_sortcop = CvSTART(cv);
-	    SAVESPTR(CvROOT(cv)->op_ppaddr);
-	    CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
 
-	    SAVESPTR(PL_curpad);
-	    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+	    if (is_xsub)
+		PL_sortcop = (OP*)cv;
+	    else {
+		PL_sortcop = CvSTART(cv);
+		SAVEVPTR(CvROOT(cv)->op_ppaddr);
+		CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+
+		SAVEVPTR(PL_curpad);
+		PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+            }
 	}
     }
     else {
 	PL_sortcop = Nullop;
-	stash = PL_curcop->cop_stash;
+	stash = CopSTASH(PL_curcop);
     }
 
     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))
-		(void)sv_2pv(*up, &PL_na);
+	    if (!PL_sortcop && !SvPOK(*up)) {
+		STRLEN n_a;
+	        if (SvAMAGIC(*up))
+	            overloading = 1;
+	        else
+		    (void)sv_2pv(*up, &n_a);
+	    }
 	    up++;
 	}
     }
@@ -743,18 +961,24 @@ 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)) {
-		bool hasargs = FALSE;
 		cx->cx_type = CXt_SUB;
 		cx->blk_gimme = G_SCALAR;
 		PUSHSUB(cx);
@@ -762,9 +986,23 @@ PP(pp_sort)
 		    (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
 	    }
 	    PL_sortcxix = cxstack_ix;
-	    qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
+
+	    if (hasargs && !is_xsub) {
+		/* This is mostly copied from pp_entersub */
+		AV *av = (AV*)PL_curpad[0];
+
+#ifndef USE_THREADS
+		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,
+		    is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
 
 	    POPBLOCK(cx,PL_curpm);
+	    PL_stack_sp = newsp;
 	    POPSTACK;
 	    CATCH_SET(oldcatch);
 	}
@@ -773,9 +1011,24 @@ 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)
-		    ? FUNC_NAME_TO_PTR(sv_cmp_locale)
-		    : FUNC_NAME_TO_PTR(sv_cmp));
+ 		    (PL_op->op_private & OPpSORT_NUMERIC)
+			? ( (PL_op->op_private & OPpSORT_INTEGER)
+			    ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
+			    : ( overloading ? amagic_ncmp : sv_ncmp))
+			: ( (PL_op->op_private & OPpLOCALE)
+			    ? ( overloading
+				? amagic_cmp_locale
+				: sv_cmp_locale_static)
+			    : ( overloading ? amagic_cmp : sv_cmp_static)));
+	    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;
@@ -788,8 +1041,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)
@@ -797,15 +1053,22 @@ PP(pp_flip)
     djSP;
 
     if (GIMME == G_ARRAY) {
-	RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
+	RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
     }
     else {
 	dTOPss;
 	SV *targ = PAD_SV(PL_op->op_targ);
-
-	if ((PL_op->op_private & OPpFLIP_LINENUM)
-	  ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
-	  : SvTRUE(sv) ) {
+ 	int flip;
+
+ 	if (PL_op->op_private & OPpFLIP_LINENUM) {
+ 	    struct io *gp_io;
+ 	    flip = PL_last_in_gv
+ 		&& (gp_io = GvIOp(PL_last_in_gv))
+ 		&& SvIV(sv) == (IV)IoLINES(gp_io);
+ 	} else {
+ 	    flip = SvTRUE(sv);
+ 	}
+ 	if (flip) {
 	    sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
 	    if (PL_op->op_flags & OPf_SPECIAL) {
 		sv_setiv(targ, 1);
@@ -815,7 +1078,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, "");
@@ -830,33 +1093,43 @@ 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') )
+	    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)
-		croak("Range iterator outside integer range");
+	    if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
+		DIE(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,na);
+	    SvPV_force(sv,n_a);
 	    while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
 		XPUSHs(sv);
 	        if (strEQ(SvPVX(sv),tmps))
@@ -885,7 +1158,7 @@ PP(pp_flop)
 /* Control. */
 
 STATIC I32
-dopoptolabel(char *label)
+S_dopoptolabel(pTHX_ char *label)
 {
     dTHR;
     register I32 i;
@@ -893,31 +1166,40 @@ dopoptolabel(char *label)
 
     for (i = cxstack_ix; i >= 0; i--) {
 	cx = &cxstack[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
-	    if (PL_dowarn)
-		warn("Exiting substitution via %s", op_name[PL_op->op_type]);
+	    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 (PL_dowarn)
-		warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
+	    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_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
-	    if (PL_dowarn)
-		warn("Exiting eval via %s", op_name[PL_op->op_type]);
+	    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 (PL_dowarn)
-		warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
+	    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:
 	    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;
 	}
     }
@@ -925,14 +1207,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;
@@ -949,33 +1231,34 @@ 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;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
 	cx = &cxstk[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	default:
 	    continue;
 	case CXt_EVAL:
 	case CXt_SUB:
-	    DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
+	case CXt_FORMAT:
+	    DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -983,18 +1266,18 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
 }
 
 STATIC I32
-dopoptoeval(I32 startingblock)
+S_dopoptoeval(pTHX_ I32 startingblock)
 {
     dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
 	cx = &cxstack[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	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;
 	}
     }
@@ -1002,32 +1285,41 @@ dopoptoeval(I32 startingblock)
 }
 
 STATIC I32
-dopoptoloop(I32 startingblock)
+S_dopoptoloop(pTHX_ I32 startingblock)
 {
     dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
 	cx = &cxstack[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
-	    if (PL_dowarn)
-		warn("Exiting substitution via %s", op_name[PL_op->op_type]);
+	    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 (PL_dowarn)
-		warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
+	    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_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
+			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
-	    if (PL_dowarn)
-		warn("Exiting eval via %s", op_name[PL_op->op_type]);
+	    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 (PL_dowarn)
-		warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
+	    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:
-	    DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
+	    DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
 	    return i;
 	}
     }
@@ -1035,24 +1327,25 @@ dopoptoloop(I32 startingblock)
 }
 
 void
-dounwind(I32 cxix)
+Perl_dounwind(pTHX_ I32 cxix)
 {
     dTHR;
     register PERL_CONTEXT *cx;
-    SV **newsp;
     I32 optype;
 
     while (cxstack_ix > cxix) {
+	SV *sv;
 	cx = &cxstack[cxstack_ix];
 	DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
-			      (long) cxstack_ix, block_type[cx->cx_type]));
+			      (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
 	/* Note: we don't need to restore the base context info till the end. */
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	    POPSUBST(cx);
 	    continue;  /* not break */
 	case CXt_SUB:
-	    POPSUB(cx);
+	    POPSUB(cx,sv);
+	    LEAVESUB(sv);
 	    break;
 	case CXt_EVAL:
 	    POPEVAL(cx);
@@ -1062,15 +1355,66 @@ dounwind(I32 cxix)
 	    break;
 	case CXt_NULL:
 	    break;
+	case CXt_FORMAT:
+	    POPFORMAT(cx);
+	    break;
 	}
 	cxstack_ix--;
     }
 }
 
+/*
+ * 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;
+	    }
+	}
+    }
+}
+
+void
+Perl_qerror(pTHX_ SV *err)
+{
+    if (PL_in_eval)
+	sv_catsv(ERRSV, err);
+    else if (PL_errors)
+	sv_catsv(PL_errors, err);
+    else
+	Perl_warn(aTHX_ "%"SVf, err);
+    ++PL_error_count;
+}
+
 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;
@@ -1078,33 +1422,37 @@ die_where(char *message)
 	SV **newsp;
 
 	if (message) {
-	    if (PL_in_eval & 4) {
-		SV **svp;
-		STRLEN klen = strlen(message);
-		
-		svp = hv_fetch(ERRHV, message, klen, TRUE);
-		if (svp) {
-		    if (!SvIOK(*svp)) {
-			static char prefix[] = "\t(in cleanup) ";
-			SV *err = ERRSV;
-			sv_upgrade(*svp, SVt_IV);
-			(void)SvIOK_only(*svp);
-			if (!SvPOK(err))
-			    sv_setpv(err,"");
-			SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
-			sv_catpvn(err, prefix, sizeof(prefix)-1);
-			sv_catpvn(err, message, klen);
+	    if (PL_in_eval & EVAL_KEEPERR) {
+		static char prefix[] = "\t(in cleanup) ";
+		SV *err = ERRSV;
+		char *e = Nullch;
+		if (!SvPOK(err))
+		    sv_setpv(err,"");
+		else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
+		    e = SvPV(err, n_a);
+		    e += n_a - msglen;
+		    if (*e != *message || strNE(e,message))
+			e = Nullch;
+		}
+		if (!e) {
+		    SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
+		    sv_catpvn(err, prefix, sizeof(prefix)-1);
+		    sv_catpvn(err, message, msglen);
+		    if (ckWARN(WARN_MISC)) {
+			STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
+			Perl_warner(aTHX_ WARN_MISC, 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) {
+	while ((cxix = dopoptoeval(cxstack_ix)) < 0
+	       && PL_curstackinfo->si_prev)
+	{
 	    dounwind(-1);
 	    POPSTACK;
 	}
@@ -1116,8 +1464,9 @@ die_where(char *message)
 		dounwind(cxix);
 
 	    POPBLOCK(cx,PL_curpm);
-	    if (cx->cx_type != CXt_EVAL) {
-		PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
+	    if (CxTYPE(cx) != CXt_EVAL) {
+		PerlIO_write(Perl_error_log, "panic: die ", 11);
+		PerlIO_write(Perl_error_log, message, msglen);
 		my_exit(1);
 	    }
 	    POPEVAL(cx);
@@ -1128,15 +1477,35 @@ die_where(char *message)
 
 	    LEAVE;
 
+	    /* LEAVE could clobber PL_curcop (see save_re_context())
+	     * XXX it might be better to find a way to avoid messing with
+	     * PL_curcop in save_re_context() instead, but this is a more
+	     * minimal fix --GSAR */
+	    PL_curcop = cx->blk_oldcop;
+
 	    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_ "%sCompilation failed in require",
+		    *msg ? msg : "Unknown error\n");
 	    }
 	    return pop_return();
 	}
     }
-    PerlIO_printf(PerlIO_stderr(), "%s",message);
-    PerlIO_flush(PerlIO_stderr());
+    if (!message)
+	message = SvPVx(ERRSV, msglen);
+    {
+#ifdef USE_SFIO
+	/* SFIO can really mess with your errno */
+	int e = errno;
+#endif
+	PerlIO *serr = Perl_error_log;
+
+	PerlIO_write(serr, message, msglen);
+	(void)PerlIO_flush(serr);
+#ifdef USE_SFIO
+	errno = e;
+#endif
+    }
     my_failure_exit();
     /* NOTREACHED */
     return 0;
@@ -1178,13 +1547,13 @@ PP(pp_caller)
     PERL_SI *top_si = PL_curstackinfo;
     I32 dbcxix;
     I32 gimme;
-    HV *hv;
+    char *stashname;
     SV *sv;
     I32 count = 0;
 
     if (MAXARG)
 	count = POPi;
-    EXTEND(SP, 6);
+    EXTEND(SP, 10);
     for (;;) {
 	/* we may be in a higher stacklevel, so dig down deeper */
 	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -1206,7 +1575,7 @@ PP(pp_caller)
     }
 
     cx = &ccstack[cxix];
-    if (ccstack[cxix].cx_type == CXt_SUB) {
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
         dbcxix = dopoptosub_at(ccstack, cxix - 1);
 	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
 	   field below is defined for any cx. */
@@ -1214,35 +1583,35 @@ PP(pp_caller)
 	    cx = &ccstack[dbcxix];
     }
 
+    stashname = CopSTASHPV(cx->blk_oldcop);
     if (GIMME != G_ARRAY) {
-	hv = cx->blk_oldcop->cop_stash;
-	if (!hv)
+	if (!stashname)
 	    PUSHs(&PL_sv_undef);
 	else {
 	    dTARGET;
-	    sv_setpv(TARG, HvNAME(hv));
+	    sv_setpv(TARG, stashname);
 	    PUSHs(TARG);
 	}
 	RETURN;
     }
 
-    hv = cx->blk_oldcop->cop_stash;
-    if (!hv)
+    if (!stashname)
 	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(newSViv((I32)cx->blk_oldcop->cop_line)));
+	PUSHs(sv_2mortal(newSVpv(stashname, 0)));
+    PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
+    PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
     if (!MAXARG)
 	RETURN;
-    if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+	/* So is ccstack[dbcxix]. */
 	sv = NEWSV(49, 0);
 	gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
 	PUSHs(sv_2mortal(sv));
 	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;
@@ -1250,20 +1619,29 @@ PP(pp_caller)
 	PUSHs(&PL_sv_undef);
     else
 	PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
-    if (cx->cx_type == CXt_EVAL) {
+    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);
+	PUSHs(&PL_sv_undef);
     }
-    else if (cx->cx_type == CXt_SUB &&
-	    cx->blk_sub.hasargs &&
-	    PL_curcop->cop_stash == PL_debstash)
+    if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
+	&& CopSTASH_eq(PL_curcop, PL_debstash))
     {
 	AV *ary = cx->blk_sub.argarray;
 	int off = AvARRAY(ary) - AvALLOC(ary);
@@ -1273,7 +1651,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)
@@ -1281,43 +1659,39 @@ PP(pp_caller)
 	Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
 	AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
     }
-    RETURN;
-}
-
-STATIC I32
-sortcv(SV *a, SV *b)
-{
-    dTHR;
-    I32 oldsaveix = PL_savestack_ix;
-    I32 oldscopeix = PL_scopestack_ix;
-    I32 result;
-    GvSV(PL_firstgv) = a;
-    GvSV(PL_secondgv) = b;
-    PL_stack_sp = PL_stack_base;
-    PL_op = PL_sortcop;
-    CALLRUNOPS();
-    if (PL_stack_sp != PL_stack_base + 1)
-	croak("Sort subroutine didn't return single value");
-    if (!SvNIOKp(*PL_stack_sp))
-	croak("Sort subroutine didn't return a numeric value");
-    result = SvIV(*PL_stack_sp);
-    while (PL_scopestack_ix > oldscopeix) {
-	LEAVE;
+    /* 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)));
+    {
+	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));
     }
-    leave_scope(oldsaveix);
-    return result;
+    RETURN;
 }
 
 PP(pp_reset)
 {
     djSP;
     char *tmps;
+    STRLEN n_a;
 
     if (MAXARG < 1)
 	tmps = "";
     else
-	tmps = POPp;
-    sv_reset(tmps, PL_curcop->cop_stash);
+	tmps = POPpx;
+    sv_reset(tmps, CopSTASH(PL_curcop));
     PUSHs(&PL_sv_yes);
     RETURN;
 }
@@ -1346,7 +1720,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;
@@ -1365,7 +1739,7 @@ PP(pp_dbstate)
 	PUSHSUB(cx);
 	CvDEPTH(cv)++;
 	(void)SvREFCNT_inc(cv);
-	SAVESPTR(PL_curpad);
+	SAVEVPTR(PL_curpad);
 	PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
 	RETURNOP(CvSTART(cv));
     }
@@ -1384,38 +1758,62 @@ PP(pp_enteriter)
     register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
     SV **svp;
+    U32 cxtype = CXt_LOOP;
+#ifdef USE_ITHREADS
+    void *iterdata;
+#endif
 
     ENTER;
     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) {
 	svp = &PL_curpad[PL_op->op_targ];		/* "my" variable */
 	SAVESPTR(*svp);
+#ifdef USE_ITHREADS
+	iterdata = (void*)PL_op->op_targ;
+	cxtype |= CXp_PADVAR;
+#endif
     }
     else {
 	GV *gv = (GV*)POPs;
-	(void)save_scalar(gv);
 	svp = &GvSV(gv);			/* symbol table variable */
+	SAVEGENERICSV(*svp);
+	*svp = NEWSV(0,0);
+#ifdef USE_ITHREADS
+	iterdata = (void*)gv;
+#endif
     }
 
     ENTER;
 
-    PUSHBLOCK(cx, CXt_LOOP, SP);
+    PUSHBLOCK(cx, cxtype, SP);
+#ifdef USE_ITHREADS
+    PUSHLOOP(cx, iterdata, MARK);
+#else
     PUSHLOOP(cx, svp, MARK);
+#endif
     if (PL_op->op_flags & OPf_STACKED) {
 	cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
 	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)
-		     croak("Range iterator outside integer range");
+		     DIE(aTHX_ "Range iterator outside integer range");
 		 cx->blk_loop.iterix = SvIV(sv);
 		 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
 	    }
@@ -1452,7 +1850,6 @@ PP(pp_leaveloop)
 {
     djSP;
     register PERL_CONTEXT *cx;
-    struct block_loop cxloop;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -1460,7 +1857,7 @@ PP(pp_leaveloop)
 
     POPBLOCK(cx,newpm);
     mark = newsp;
-    POPLOOP1(cx);	/* Delay POPLOOP2 until stack values are safe */
+    newsp = PL_stack_base + cx->blk_loop.resetsp;
 
     TAINT_NOT;
     if (gimme == G_VOID)
@@ -1480,7 +1877,7 @@ PP(pp_leaveloop)
     SP = newsp;
     PUTBACK;
 
-    POPLOOP2();		/* Stack values are safe: release loop vars ... */
+    POPLOOP(cx);	/* Stack values are safe: release loop vars ... */
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
     LEAVE;
@@ -1494,15 +1891,18 @@ PP(pp_return)
     djSP; dMARK;
     I32 cxix;
     register PERL_CONTEXT *cx;
-    struct block_sub cxsub;
     bool popsub2 = FALSE;
+    bool clear_errsv = FALSE;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
     I32 optype = 0;
+    SV *sv;
 
     if (PL_curstackinfo->si_type == PERLSI_SORT) {
-	if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
+	if (cxstack_ix == PL_sortcxix
+	    || dopoptosub(cxstack_ix) <= PL_sortcxix)
+	{
 	    if (cxstack_ix > PL_sortcxix)
 		dounwind(PL_sortcxix);
 	    AvARRAY(PL_curstack)[1] = *SP;
@@ -1513,49 +1913,64 @@ 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);
 
     POPBLOCK(cx,newpm);
-    switch (cx->cx_type) {
+    switch (CxTYPE(cx)) {
     case CXt_SUB:
-	POPSUB1(cx);	/* Delay POPSUB2 until stack values are safe */
 	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();
 	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);
+	    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:
+	POPFORMAT(cx);
+	break;
     default:
-	DIE("panic: return");
+	DIE(aTHX_ "panic: return");
     }
 
     TAINT_NOT;
     if (gimme == G_SCALAR) {
 	if (MARK < SP) {
 	    if (popsub2) {
-		if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+		if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
 		    if (SvTEMP(TOPs)) {
 			*++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) {
@@ -1569,11 +1984,16 @@ PP(pp_return)
 
     /* Stack values are safe: */
     if (popsub2) {
-	POPSUB2();	/* release CV and @_ ... */
+	POPSUB(cx,sv);	/* release CV and @_ ... */
     }
+    else
+	sv = Nullsv;
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
     LEAVE;
+    LEAVESUB(sv);
+    if (clear_errsv)
+	sv_setpv(ERRSV,"");
     return pop_return();
 }
 
@@ -1582,38 +2002,37 @@ PP(pp_last)
     djSP;
     I32 cxix;
     register PERL_CONTEXT *cx;
-    struct block_loop cxloop;
-    struct block_sub cxsub;
     I32 pop2 = 0;
     I32 gimme;
     I32 optype;
     OP *nextop;
     SV **newsp;
     PMOP *newpm;
-    SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+    SV **mark;
+    SV *sv = Nullsv;
 
     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 loop 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);
 
     POPBLOCK(cx,newpm);
-    switch (cx->cx_type) {
+    mark = newsp;
+    switch (CxTYPE(cx)) {
     case CXt_LOOP:
-	POPLOOP1(cx);	/* Delay POPLOOP2 until stack values are safe */
 	pop2 = CXt_LOOP;
-	nextop = cxloop.last_op->op_next;
+	newsp = PL_stack_base + cx->blk_loop.resetsp;
+	nextop = cx->blk_loop.last_op->op_next;
 	break;
     case CXt_SUB:
-	POPSUB1(cx);	/* Delay POPSUB2 until stack values are safe */
 	pop2 = CXt_SUB;
 	nextop = pop_return();
 	break;
@@ -1621,8 +2040,12 @@ PP(pp_last)
 	POPEVAL(cx);
 	nextop = pop_return();
 	break;
+    case CXt_FORMAT:
+	POPFORMAT(cx);
+	nextop = pop_return();
+	break;
     default:
-	DIE("panic: last");
+	DIE(aTHX_ "panic: last");
     }
 
     TAINT_NOT;
@@ -1646,16 +2069,17 @@ PP(pp_last)
     /* Stack values are safe: */
     switch (pop2) {
     case CXt_LOOP:
-	POPLOOP2();	/* release loop vars ... */
+	POPLOOP(cx);	/* release loop vars ... */
 	LEAVE;
 	break;
     case CXt_SUB:
-	POPSUB2();	/* release CV and @_ ... */
+	POPSUB(cx,sv);	/* release CV and @_ ... */
 	break;
     }
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
     LEAVE;
+    LEAVESUB(sv);
     return nextop;
 }
 
@@ -1663,24 +2087,27 @@ PP(pp_next)
 {
     I32 cxix;
     register PERL_CONTEXT *cx;
-    I32 oldsave;
+    I32 inner;
 
     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 loop 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);
 
+    /* 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;
 }
 
@@ -1693,12 +2120,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 loop 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);
@@ -1710,14 +2137,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 ||
@@ -1725,7 +2152,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) {
@@ -1744,7 +2171,7 @@ dofindlabel(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;
 	}
     }
@@ -1754,7 +2181,7 @@ dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
 
 PP(pp_dump)
 {
-    return pp_goto(ARGS);
+    return pp_goto();
     /*NOTREACHED*/
 }
 
@@ -1768,10 +2195,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) {
@@ -1782,27 +2211,38 @@ PP(pp_goto)
 	    I32 items = 0;
 	    I32 oldsave;
 
+	retry:
 	    if (!CvROOT(cv) && !CvXSUB(cv)) {
-		if (CvGV(cv)) {
-		    SV *tmpstr = sv_newmortal();
-		    gv_efullname3(tmpstr, CvGV(cv), Nullch);
-		    DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
+		GV *gv = CvGV(cv);
+		GV *autogv;
+		if (gv) {
+		    SV *tmpstr;
+		    /* autoloaded stub? */
+		    if (cv != GvCV(gv) && (cv = GvCV(gv)))
+			goto retry;
+		    autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
+					  GvNAMELEN(gv), FALSE);
+		    if (autogv && (cv = GvCV(autogv)))
+			goto retry;
+		    tmpstr = sv_newmortal();
+		    gv_efullname3(tmpstr, gv, Nullch);
+		    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 (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
-		DIE("Can't goto subroutine from an eval-string");
+	    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
+		DIE(aTHX_ "Can't goto subroutine from an eval-string");
 	    mark = PL_stack_sp;
-	    if (cx->cx_type == CXt_SUB &&
-		cx->blk_sub.hasargs) {   /* put @_ back onto stack */
+	    if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
+		/* put @_ back onto stack */
 		AV* av = cx->blk_sub.argarray;
 		
 		items = AvFILLp(av) + 1;
@@ -1814,12 +2254,17 @@ PP(pp_goto)
 		SvREFCNT_dec(GvAV(PL_defgv));
 		GvAV(PL_defgv) = cx->blk_sub.savearray;
 #endif /* USE_THREADS */
-		AvREAL_off(av);
-		av_clear(av);
+		/* abandon @_ if it got reified */
+		if (AvREAL(av)) {
+		    (void)sv_2mortal((SV*)av);	/* delay until return */
+		    av = newAV();
+		    av_extend(av, items-1);
+		    AvFLAGS(av) = AVf_REIFY;
+		    PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
+		}
 	    }
 	    else if (CvXSUB(cv)) {	/* put GvAV(defgv) back onto stack */
 		AV* av;
-		int i;
 #ifdef USE_THREADS
 		av = (AV*)PL_curpad[0];
 #else
@@ -1831,7 +2276,7 @@ PP(pp_goto)
 		Copy(AvARRAY(av), PL_stack_sp, items, SV*);
 		PL_stack_sp += items;
 	    }
-	    if (cx->cx_type == CXt_SUB &&
+	    if (CxTYPE(cx) == CXt_SUB &&
 		!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
 		SvREFCNT_dec(cx->blk_sub.cv);
 	    oldsave = PL_scopestack[PL_scopestack_ix - 1];
@@ -1840,26 +2285,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! */
@@ -1870,7 +2318,7 @@ PP(pp_goto)
 	    else {
 		AV* padlist = CvPADLIST(cv);
 		SV** svp = AvARRAY(padlist);
-		if (cx->cx_type == CXt_EVAL) {
+		if (CxTYPE(cx) == CXt_EVAL) {
 		    PL_in_eval = cx->blk_eval.old_in_eval;
 		    PL_eval_root = cx->blk_eval.old_eval_root;
 		    cx->cx_type = CXt_SUB;
@@ -1882,15 +2330,16 @@ PP(pp_goto)
 		if (CvDEPTH(cv) < 2)
 		    (void)SvREFCNT_inc(cv);
 		else {	/* save temporaries on recursion? */
-		    if (CvDEPTH(cv) == 100 && PL_dowarn)
+		    if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
 			sub_crush_depth(cv);
 		    if (CvDEPTH(cv) > AvFILLp(padlist)) {
 			AV *newpad = newAV();
 			SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
 			I32 ix = AvFILLp((AV*)svp[1]);
+			I32 names_fill = AvFILLp((AV*)svp[0]);
 			svp = AvARRAY(svp[0]);
 			for ( ;ix > 0; ix--) {
-			    if (svp[ix] != &PL_sv_undef) {
+			    if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
 				char *name = SvPVX(svp[ix]);
 				if ((SvFLAGS(svp[ix]) & SVf_FAKE)
 				    || *name == '&')
@@ -1909,6 +2358,9 @@ PP(pp_goto)
 				    SvPADMY_on(sv);
 				}
 			    }
+			    else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+				av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
+			    }
 			    else {
 				av_store(newpad, ix, sv = NEWSV(0,0));
 				SvPADTMP_on(sv);
@@ -1939,7 +2391,7 @@ PP(pp_goto)
 		    }
 		}
 #endif /* USE_THREADS */		
-		SAVESPTR(PL_curpad);
+		SAVEVPTR(PL_curpad);
 		PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
 #ifndef USE_THREADS
 		if (cx->blk_sub.hasargs)
@@ -1952,6 +2404,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;
 
@@ -1970,7 +2423,7 @@ PP(pp_goto)
 		    }
 		    Copy(mark,AvARRAY(av),items,SV*);
 		    AvFILLp(av) = items - 1;
-		    
+		    assert(!AvREAL(av));
 		    while (items--) {
 			if (*mark)
 			    SvTEMP_off(*mark);
@@ -1986,27 +2439,30 @@ PP(pp_goto)
 		    CV *gotocv;
 		    
 		    if (PERLDB_SUB_NN) {
-			SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
+			SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
 		    } else {
 			save_item(sv);
 			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;
@@ -2020,7 +2476,7 @@ PP(pp_goto)
 	*enterops = 0;
 	for (ix = cxstack_ix; ix >= 0; ix--) {
 	    cx = &cxstack[ix];
-	    switch (cx->cx_type) {
+	    switch (CxTYPE(cx)) {
 	    case CXt_EVAL:
 		gotoprobe = PL_eval_root; /* XXX not good for nested eval */
 		break;
@@ -2041,22 +2497,25 @@ PP(pp_goto)
 		    break;
 		}
 		/* FALL THROUGH */
+	    case CXt_FORMAT:
 	    case CXt_NULL:
-		DIE("Can't \"goto\" outside a block");
+		DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
 	    default:
 		if (ix)
-		    DIE("panic: goto");
+		    DIE(aTHX_ "panic: 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)
-	    DIE("Can't find label %s", label);
+	    DIE(aTHX_ "Can't find label %s", label);
 
 	/* pop unwanted frames */
 
@@ -2080,9 +2539,8 @@ 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",
-			label);
-		(CALLOP->op_ppaddr)(ARGS);
+		    DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
+		CALL_FPTR(PL_op->op_ppaddr)(aTHX);
 	    }
 	    PL_op = oldop;
 	}
@@ -2090,7 +2548,7 @@ PP(pp_goto)
 
     if (do_dump) {
 #ifdef VMS
-	if (!retop) retop = main_start;
+	if (!retop) retop = PL_main_start;
 #endif
 	PL_restartop = retop;
 	PL_do_undump = TRUE;
@@ -2101,11 +2559,6 @@ PP(pp_goto)
 	PL_do_undump = FALSE;
     }
 
-    if (PL_top_env->je_prev) {
-        PL_restartop = retop;
-        JMPENV_JUMP(3);
-    }
-
     RETURNOP(retop);
 }
 
@@ -2118,11 +2571,12 @@ 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
     }
+    PL_exit_flags |= PERL_EXIT_EXPECTED;
     my_exit(anum);
     PUSHs(&PL_sv_undef);
     RETURN;
@@ -2132,11 +2586,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;
@@ -2144,8 +2598,8 @@ PP(pp_nswitch)
 	match = 0;
     else if (match > cCOP->uop.scop.scop_max)
 	match = cCOP->uop.scop.scop_max;
-    op = cCOP->uop.scop.scop_next[match];
-    RETURNOP(op);
+    PL_op = cCOP->uop.scop.scop_next[match];
+    RETURNOP(PL_op);
 }
 
 PP(pp_cswitch)
@@ -2153,25 +2607,26 @@ PP(pp_cswitch)
     djSP;
     register I32 match;
 
-    if (multiline)
-	op = op->op_next;			/* can't assume anything */
+    if (PL_multiline)
+	PL_op = PL_op->op_next;			/* can't assume anything */
     else {
-	match = *(SvPVx(GvSV(cCOP->cop_gv), 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;
 	else if (match > cCOP->uop.scop.scop_max)
 	    match = cCOP->uop.scop.scop_max;
-	op = cCOP->uop.scop.scop_next[match];
+	PL_op = cCOP->uop.scop.scop_next[match];
     }
-    RETURNOP(op);
+    RETURNOP(PL_op);
 }
 #endif
 
 /* 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);
@@ -2194,37 +2649,59 @@ save_lines(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;
+}
+
 STATIC OP *
-docatch(OP *o)
+S_docatch(pTHX_ OP *o)
 {
     dTHR;
     int ret;
     OP *oldop = PL_op;
+    volatile PERL_SI *cursi = PL_curstackinfo;
     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
+    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) {
-    default:				/* topmost level handles it */
+    case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+	docatch_body();
+#endif
+	break;
+    case 3:
+	if (PL_restartop && cursi == PL_curstackinfo) {
+	    PL_op = PL_restartop;
+	    PL_restartop = 0;
+	    goto redo_body;
+	}
+	/* FALL THROUGH */
+    default:
 	JMPENV_POP;
 	PL_op = oldop;
 	JMPENV_JUMP(ret);
 	/* NOTREACHED */
-    case 3:
-	if (!PL_restartop) {
-	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
-	    break;
-	}
-	PL_op = PL_restartop;
-	PL_restartop = 0;
-	/* FALL THROUGH */
-    case 0:
-        CALLRUNOPS();
-	break;
     }
     JMPENV_POP;
     PL_op = oldop;
@@ -2232,7 +2709,7 @@ docatch(OP *o)
 }
 
 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. */
@@ -2243,8 +2720,9 @@ sv_compile_2op(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;
@@ -2252,11 +2730,23 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
     SAVETMPS;
     /* switch to eval mode */
 
-    SAVESPTR(PL_compiling.cop_filegv);
-    SAVEI16(PL_compiling.cop_line);
-    sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
-    PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
-    PL_compiling.cop_line = 1;
+    if (PL_curcop == &PL_compiling) {
+	SAVECOPSTASH_FREE(&PL_compiling);
+	CopSTASH_set(&PL_compiling, PL_curstash);
+    }
+    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
        (i.e. before run-time proper). To work around the coredump that
@@ -2266,51 +2756,54 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
     SAVEHINTS();
 #ifdef OP_IN_REGISTER
-    opsave = op;
+    PL_opsave = op;
 #else
-    SAVEPPTR(PL_op);
+    SAVEVPTR(PL_op);
 #endif
     PL_hints = 0;
 
     PL_op = &dummy;
-    PL_op->op_type = 0;			/* Avoid uninit warning. */
+    PL_op->op_type = OP_ENTEREVAL;
     PL_op->op_flags = 0;			/* Avoid uninit warning. */
     PUSHBLOCK(cx, CXt_EVAL, SP);
-    PUSHEVAL(cx, 0, compiling.cop_filegv);
+    PUSHEVAL(cx, 0, Nullgv);
     rop = doeval(G_SCALAR, startop);
     POPBLOCK(cx,PL_curpm);
     POPEVAL(cx);
 
     (*startop)->op_type = OP_NULL;
-    (*startop)->op_ppaddr = ppaddr[OP_NULL];
+    (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
     lex_end();
     *avp = (AV*)SvREFCNT_inc(PL_comppad);
     LEAVE;
+    if (PL_curcop == &PL_compiling)
+	PL_compiling.op_private = PL_hints;
 #ifdef OP_IN_REGISTER
-    op = opsave;
+    op = PL_opsave;
 #endif
     return rop;
 }
 
 /* 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;
-    HV *newstash;
     CV *caller;
     AV* comppadlist;
     I32 i;
 
-    PL_in_eval = 1;
+    PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+		  ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
+		  : EVAL_INEVAL);
 
     PUSHMARK(SP);
 
     /* set up a scratch pad */
 
     SAVEI32(PL_padix);
-    SAVESPTR(PL_curpad);
+    SAVEVPTR(PL_curpad);
     SAVESPTR(PL_comppad);
     SAVESPTR(PL_comppad_name);
     SAVEI32(PL_comppad_name_fill);
@@ -2320,9 +2813,9 @@ doeval(int gimme, OP** startop)
     caller = PL_compcv;
     for (i = cxstack_ix - 1; i >= 0; i--) {
 	PERL_CONTEXT *cx = &cxstack[i];
-	if (cx->cx_type == CXt_EVAL)
+	if (CxTYPE(cx) == CXt_EVAL)
 	    break;
-	else if (cx->cx_type == CXt_SUB) {
+	else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
 	    caller = cx->blk_sub.cv;
 	    break;
 	}
@@ -2331,7 +2824,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);
@@ -2346,7 +2839,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 */
@@ -2357,21 +2850,24 @@ doeval(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);
 
     /* make sure we compile in the right package */
 
-    newstash = PL_curcop->cop_stash;
-    if (PL_curstash != newstash) {
+    if (CopSTASH_ne(PL_curcop, PL_curstash)) {
 	SAVESPTR(PL_curstash);
-	PL_curstash = newstash;
+	PL_curstash = CopSTASH(PL_curcop);
     }
     SAVESPTR(PL_beginav);
     PL_beginav = newAV();
     SAVEFREESV(PL_beginav);
+    SAVEI32(PL_error_count);
 
     /* try to compile it */
 
@@ -2380,9 +2876,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) {
@@ -2390,7 +2886,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);
@@ -2405,14 +2902,17 @@ 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");
-	} else if (startop) {
-	    char* msg = SvPVx(ERRSV, PL_na);
+	    char* msg = SvPVx(ERRSV, n_a);
+	    DIE(aTHX_ "%sCompilation failed in require",
+		*msg ? msg : "Unknown error\n");
+	}
+	else if (startop) {
+	    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);
@@ -2426,7 +2926,7 @@ doeval(int gimme, OP** startop)
     }
     SvREFCNT_dec(PL_rs);
     PL_rs = SvREFCNT_inc(PL_nrs);
-    PL_compiling.cop_line = 0;
+    CopLINE_set(&PL_compiling, 0);
     if (startop) {
 	*startop = PL_eval_root;
 	SvREFCNT_dec(CvOUTSIDE(PL_compcv));
@@ -2444,13 +2944,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);
+	    XPUSHs((SV*)CopFILEGV(&PL_compiling));
 	    PUTBACK;
-	    perl_call_sv((SV*)cv, G_DISCARD);
+	    call_sv((SV*)cv, G_DISCARD);
 	}
     }
 
@@ -2459,6 +2959,7 @@ doeval(int gimme, OP** startop)
     CvDEPTH(PL_compcv) = 1;
     SP = PL_stack_base + POPMARK;		/* pop original mark */
     PL_op = saveop;			/* The caller may need it. */
+    PL_lex_state = LEX_NOTPARSING;	/* $^S needs this. */
 #ifdef USE_THREADS
     MUTEX_LOCK(&PL_eval_mutex);
     PL_eval_owner = 0;
@@ -2469,30 +2970,118 @@ doeval(int gimme, OP** startop)
     RETURNOP(PL_eval_start);
 }
 
-PP(pp_require)
+STATIC PerlIO *
+S_doopen_pmc(pTHX_ const char *name, const char *mode)
 {
-    djSP;
-    register PERL_CONTEXT *cx;
-    SV *sv;
-    char *name;
+    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;
+    register PERL_CONTEXT *cx;
+    SV *sv;
+    char *name;
     STRLEN len;
     char *tryname;
     SV *namesv = Nullsv;
     SV** svp;
     I32 gimme = G_SCALAR;
     PerlIO *tryrsfp = 0;
+    STRLEN n_a;
+    int filter_has_file = 0;
+    GV *filter_child_proc = 0;
+    SV *filter_state = 0;
+    SV *filter_sub = 0;
 
     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);
-	RETPUSHYES;
+    if (SvNIOKp(sv)) {
+	if (SvPOK(sv) && SvNOK(sv)) {		/* require v5.6.1 */
+	    UV rev = 0, ver = 0, sver = 0;
+	    STRLEN len;
+	    U8 *s = (U8*)SvPVX(sv);
+	    U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
+	    if (s < end) {
+		rev = utf8_to_uv(s, end - s, &len, 0);
+		s += len;
+		if (s < end) {
+		    ver = utf8_to_uv(s, end - s, &len, 0);
+		    s += len;
+		    if (s < end)
+			sver = utf8_to_uv(s, end - s, &len, 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 "
+		    "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
+		    PERL_VERSION, PERL_SUBVERSION);
+	    }
+	    RETPUSHYES;
+	}
+	else if (!SvPOKp(sv)) {			/* require 5.005_03 */
+	    if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
+		+ ((NV)PERL_SUBVERSION/(NV)1000000)
+		+ 0.00000099 < SvNV(sv))
+	    {
+		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;
+	}
     }
     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)) &&
@@ -2501,26 +3090,25 @@ PP(pp_require)
 
     /* prepare to compile file */
 
-    if (*name == '/' ||
-	(*name == '.' && 
-	    (name[1] == '/' ||
-	     (name[1] == '.' && name[2] == '/')))
-#ifdef DOSISH
-      || (name[0] && name[1] == ':')
-#endif
-#ifdef WIN32
-      || (name[0] == '\\' && name[1] == '\\')	/* UNC path */
-#endif
-#ifdef VMS
-	|| (strchr(name,':')  || ((*name == '[' || *name == '<') &&
-	    (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
-#endif
-    )
+    if (PERL_FILE_IS_ABSOLUTE(name)
+	|| (*name == '.' && (name[1] == '/' ||
+			     (name[1] == '.' && name[2] == '/'))))
     {
 	tryname = name;
-	tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
+	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
@@ -2530,78 +3118,218 @@ PP(pp_require)
 	{
 	    namesv = NEWSV(806, 0);
 	    for (i = 0; i <= AvFILL(ar); i++) {
-		char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
+		SV *dirsv = *av_fetch(ar, i, TRUE);
+
+		if (SvROK(dirsv)) {
+		    int count;
+		    SV *loader = dirsv;
+
+		    if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
+			loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
+		    }
+
+		    Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
+				   PTR2UV(SvANY(loader)), name);
+		    tryname = SvPVX(namesv);
+		    tryrsfp = 0;
+
+		    ENTER;
+		    SAVETMPS;
+		    EXTEND(SP, 2);
+
+		    PUSHMARK(SP);
+		    PUSHs(dirsv);
+		    PUSHs(sv);
+		    PUTBACK;
+		    count = call_sv(loader, G_ARRAY);
+		    SPAGAIN;
+
+		    if (count > 0) {
+			int i = 0;
+			SV *arg;
+
+			SP -= count - 1;
+			arg = SP[i++];
+
+			if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
+			    arg = SvRV(arg);
+			}
+
+			if (SvTYPE(arg) == SVt_PVGV) {
+			    IO *io = GvIO((GV *)arg);
+
+			    ++filter_has_file;
+
+			    if (io) {
+				tryrsfp = IoIFP(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
+				       unreadable (closed?)  I've tried to
+				       save the gv to manage the lifespan of
+				       the pipe, but this didn't help. XXX */
+				    filter_child_proc = (GV *)arg;
+				    (void)SvREFCNT_inc(filter_child_proc);
+				}
+				else {
+				    if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+					PerlIO_close(IoOFP(io));
+				    }
+				    IoIFP(io) = Nullfp;
+				    IoOFP(io) = Nullfp;
+				}
+			    }
+
+			    if (i < count) {
+				arg = SP[i++];
+			    }
+			}
+
+			if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
+			    filter_sub = arg;
+			    (void)SvREFCNT_inc(filter_sub);
+
+			    if (i < count) {
+				filter_state = SP[i];
+				(void)SvREFCNT_inc(filter_state);
+			    }
+
+			    if (tryrsfp == 0) {
+				tryrsfp = PerlIO_open("/dev/null",
+						      PERL_SCRIPT_MODE);
+			    }
+			}
+		    }
+
+		    PUTBACK;
+		    FREETMPS;
+		    LEAVE;
+
+		    if (tryrsfp) {
+			break;
+		    }
+
+		    filter_has_file = 0;
+		    if (filter_child_proc) {
+			SvREFCNT_dec(filter_child_proc);
+			filter_child_proc = 0;
+		    }
+		    if (filter_state) {
+			SvREFCNT_dec(filter_state);
+			filter_state = 0;
+		    }
+		    if (filter_sub) {
+			SvREFCNT_dec(filter_sub);
+			filter_sub = 0;
+		    }
+		}
+		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)
-		    continue;
-		sv_setpv(namesv, unixdir);
-		sv_catpv(namesv, unixname);
+		    char *unixdir;
+		    if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
+			continue;
+		    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
-		tryname = SvPVX(namesv);
-		tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
-		if (tryrsfp) {
-		    if (tryname[0] == '.' && tryname[1] == '/')
-			tryname += 2;
-		    break;
+#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] == '/')
+			    tryname += 2;
+			break;
+		    }
 		}
 	    }
 	}
     }
-    SAVESPTR(PL_compiling.cop_filegv);
-    PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
+    SAVECOPFILE_FREE(&PL_compiling);
+    CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
     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;
     }
+    else
+	SETERRNO(0, SS$_NORMAL);
 
     /* Assume success here to prevent recursive requirement. */
     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
-	newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
+		   newSVpv(CopFILE(&PL_compiling), 0), 0 );
 
     ENTER;
     SAVETMPS;
-    lex_start(sv_2mortal(newSVpv("",0)));
-    if (PL_rsfp_filters){
- 	save_aptr(&PL_rsfp_filters);
-	PL_rsfp_filters = NULL;
-    }
+    lex_start(sv_2mortal(newSVpvn("",0)));
+    SAVEGENERICSV(PL_rsfp_filters);
+    PL_rsfp_filters = Nullav;
 
     PL_rsfp = tryrsfp;
-    name = savepv(name);
-    SAVEFREEPV(name);
     SAVEHINTS();
     PL_hints = 0;
- 
-    /* switch to eval mode */
+    SAVESPTR(PL_compiling.cop_warnings);
+    if (PL_dowarn & G_WARN_ALL_ON)
+        PL_compiling.cop_warnings = pWARN_ALL ;
+    else if (PL_dowarn & G_WARN_ALL_OFF)
+        PL_compiling.cop_warnings = pWARN_NONE ;
+    else 
+        PL_compiling.cop_warnings = pWARN_STD ;
+
+    if (filter_sub || filter_child_proc) {
+	SV *datasv = filter_add(run_user_filter, Nullsv);
+	IoLINES(datasv) = filter_has_file;
+	IoFMT_GV(datasv) = (GV *)filter_child_proc;
+	IoTOP_GV(datasv) = (GV *)filter_state;
+	IoBOTTOM_GV(datasv) = (GV *)filter_sub;
+    }
 
+    /* switch to eval mode */
     push_return(PL_op->op_next);
     PUSHBLOCK(cx, CXt_EVAL, SP);
-    PUSHEVAL(cx, name, compiling.cop_filegv);
+    PUSHEVAL(cx, name, Nullgv);
 
-    PL_compiling.cop_line = 0;
+    SAVECOPLINE(&PL_compiling);
+    CopLINE_set(&PL_compiling, 0);
 
     PUTBACK;
 #ifdef USE_THREADS
@@ -2617,7 +3345,7 @@ PP(pp_require)
 
 PP(pp_dofile)
 {
-    return pp_require(ARGS);
+    return pp_require();
 }
 
 PP(pp_entereval)
@@ -2626,7 +3354,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;
@@ -2641,10 +3370,19 @@ PP(pp_entereval)
  
     /* switch to eval mode */
 
-    SAVESPTR(PL_compiling.cop_filegv);
-    sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
-    PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
-    PL_compiling.cop_line = 1;
+    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
        (i.e. before run-time proper). To work around the coredump that
@@ -2654,15 +3392,22 @@ PP(pp_entereval)
     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
     SAVEHINTS();
     PL_hints = PL_op->op_targ;
+    SAVESPTR(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);
-    PUSHBLOCK(cx, CXt_EVAL, SP);
-    PUSHEVAL(cx, 0, compiling.cop_filegv);
+    PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
+    PUSHEVAL(cx, 0, Nullgv);
 
     /* prepare to compile string */
 
     if (PERLDB_LINE && PL_curstash != PL_debstash)
-	save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
+	save_lines(CopFILEAV(&PL_compiling), PL_linestr);
     PUTBACK;
 #ifdef USE_THREADS
     MUTEX_LOCK(&PL_eval_mutex);
@@ -2711,6 +3456,7 @@ PP(pp_leaveeval)
 	    MEXTEND(mark,0);
 	    *MARK = &PL_sv_undef;
 	}
+	SP = MARK;
     }
     else {
 	/* in case LEAVE wipes old return values */
@@ -2723,35 +3469,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);
@@ -2763,9 +3482,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 = die("%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 {
@@ -2787,11 +3506,11 @@ 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. */
 
-    PL_in_eval = 1;
+    PL_in_eval = EVAL_INEVAL;
     sv_setpv(ERRSV,"");
     PUTBACK;
     return DOCATCH(PL_op->op_next);
@@ -2845,7 +3564,7 @@ PP(pp_leavetry)
 }
 
 STATIC void
-doparseform(SV *sv)
+S_doparseform(pTHX_ SV *sv)
 {
     STRLEN len;
     register char *s = SvPV_force(sv, len);
@@ -2862,7 +3581,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;
@@ -2966,6 +3685,24 @@ doparseform(SV *sv)
 		}
 		*fpc++ = s - base;		/* fieldsize for FETCH */
 		*fpc++ = FF_DECIMAL;
+                *fpc++ = arg;
+            }
+            else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
+                arg = ischop ? 512 : 0;
+		base = s - 1;
+                s++;                                /* skip the '0' first */
+                while (*s == '#')
+                    s++;
+                if (*s == '.') {
+                    char *f;
+                    s++;
+                    f = s;
+                    while (*s == '#')
+                        s++;
+                    arg |= 256 + (s - f);
+                }
+                *fpc++ = s - base;                /* fieldsize for FETCH */
+                *fpc++ = FF_0DECIMAL;
 		*fpc++ = arg;
 	    }
 	    else {
@@ -3023,692 +3760,674 @@ doparseform(SV *sv)
 }
 
 /*
- * The rest of this file was derived from source code contributed
- * by Tom Horsley.
+ * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
+ *
+ * The original code was written in conjunction with BSD Computer Software
+ * Research Group at University of California, Berkeley.
+ *
+ * See also: "Optimistic Merge Sort" (SODA '92)
+ *      
+ * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
+ *
+ * The code can be distributed under the same terms as Perl itself.
  *
- * NOTE: this code was derived from Tom Horsley's qsort replacement
- * and should not be confused with the original code.
  */
 
-/* Copyright (C) Tom Horsley, 1997. All rights reserved.
+#ifdef	TESTHARNESS
+#include <sys/types.h>
+typedef	void SV;
+#define pTHXo_
+#define pTHX_
+#define STATIC
+#define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
+#define	Safefree(VAR) free(VAR)
+typedef int  (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
+#endif	/* TESTHARNESS */
+
+typedef char * aptr;		/* pointer for arithmetic on sizes */
+typedef SV * gptr;		/* pointers in our lists */
+
+/* Binary merge internal sort, with a few special mods
+** for the special perl environment it now finds itself in.
+**
+** Things that were once options have been hotwired
+** to values suitable for this use.  In particular, we'll always
+** initialize looking for natural runs, we'll always produce stable
+** output, and we'll always do Peter McIlroy's binary merge.
+*/
 
-   Permission granted to distribute under the same terms as perl which are
-   (briefly):
+/* Pointer types for arithmetic and storage and convenience casts */
 
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of either:
+#define	APTR(P)	((aptr)(P))
+#define	GPTP(P)	((gptr *)(P))
+#define GPPP(P) ((gptr **)(P))
 
-	a) the GNU General Public License as published by the Free
-	Software Foundation; either version 1, or (at your option) any
-	later version, or
 
-	b) the "Artistic License" which comes with this Kit.
+/* byte offset from pointer P to (larger) pointer Q */
+#define	BYTEOFF(P, Q) (APTR(Q) - APTR(P))
 
-   Details on the perl license can be found in the perl source code which
-   may be located via the www.perl.com web page.
+#define PSIZE sizeof(gptr)
 
-   This is the most wonderfulest possible qsort I can come up with (and
-   still be mostly portable) My (limited) tests indicate it consistently
-   does about 20% fewer calls to compare than does the qsort in the Visual
-   C++ library, other vendors may vary.
+/* If PSIZE is power of 2, make PSHIFT that power, if that helps */
 
-   Some of the ideas in here can be found in "Algorithms" by Sedgewick,
-   others I invented myself (or more likely re-invented since they seemed
-   pretty obvious once I watched the algorithm operate for a while).
+#ifdef	PSHIFT
+#define	PNELEM(P, Q)	(BYTEOFF(P,Q) >> (PSHIFT))
+#define	PNBYTE(N)	((N) << (PSHIFT))
+#define	PINDEX(P, N)	(GPTP(APTR(P) + PNBYTE(N)))
+#else
+/* Leave optimization to compiler */
+#define	PNELEM(P, Q)	(GPTP(Q) - GPTP(P))
+#define	PNBYTE(N)	((N) * (PSIZE))
+#define	PINDEX(P, N)	(GPTP(P) + (N))
+#endif
 
-   Most of this code was written while watching the Marlins sweep the Giants
-   in the 1997 National League Playoffs - no Braves fans allowed to use this
-   code (just kidding :-).
+/* Pointer into other corresponding to pointer into this */
+#define	POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
 
-   I realize that if I wanted to be true to the perl tradition, the only
-   comment in this file would be something like:
+#define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
 
-   ...they shuffled back towards the rear of the line. 'No, not at the
-   rear!'  the slave-driver shouted. 'Three files up. And stay there...
 
-   However, I really needed to violate that tradition just so I could keep
-   track of what happens myself, not to mention some poor fool trying to
-   understand this years from now :-).
+/* Runs are identified by a pointer in the auxilliary list.
+** The pointer is at the start of the list,
+** and it points to the start of the next list.
+** NEXT is used as an lvalue, too.
 */
 
-/* ********************************************************** Configuration */
+#define	NEXT(P)		(*GPPP(P))
 
-#ifndef QSORT_ORDER_GUESS
-#define QSORT_ORDER_GUESS 2	/* Select doubling version of the netBSD trick */
-#endif
 
-/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
-   future processing - a good max upper bound is log base 2 of memory size
-   (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
-   safely be smaller than that since the program is taking up some space and
-   most operating systems only let you grab some subset of contiguous
-   memory (not to mention that you are normally sorting data larger than
-   1 byte element size :-).
+/* PTHRESH is the minimum number of pairs with the same sense to justify
+** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
+** not just elements, so PTHRESH == 8 means a run of 16.
 */
-#ifndef QSORT_MAX_STACK
-#define QSORT_MAX_STACK 32
-#endif
 
-/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
-   Anything bigger and we use qsort. If you make this too small, the qsort
-   will probably break (or become less efficient), because it doesn't expect
-   the middle element of a partition to be the same as the right or left -
-   you have been warned).
+#define	PTHRESH (8)
+
+/* RTHRESH is the number of elements in a run that must compare low
+** to the low element from the opposing run before we justify
+** doing a binary rampup instead of single stepping.
+** In random input, N in a row low should only happen with
+** probability 2^(1-N), so we can risk that we are dealing
+** with orderly input without paying much when we aren't.
 */
-#ifndef QSORT_BREAK_EVEN
-#define QSORT_BREAK_EVEN 6
-#endif
 
-/* ************************************************************* Data Types */
+#define RTHRESH (6)
+
 
-/* hold left and right index values of a partition waiting to be sorted (the
-   partition includes both left and right - right is NOT one past the end or
-   anything like that).
+/*
+** Overview of algorithm and variables.
+** The array of elements at list1 will be organized into runs of length 2,
+** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
+** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
+**
+** Unless otherwise specified, pair pointers address the first of two elements.
+**
+** b and b+1 are a pair that compare with sense ``sense''.
+** b is the ``bottom'' of adjacent pairs that might form a longer run.
+**
+** p2 parallels b in the list2 array, where runs are defined by
+** a pointer chain.
+**
+** t represents the ``top'' of the adjacent pairs that might extend
+** the run beginning at b.  Usually, t addresses a pair
+** that compares with opposite sense from (b,b+1).
+** However, it may also address a singleton element at the end of list1,
+** or it may be equal to ``last'', the first element beyond list1.
+**
+** r addresses the Nth pair following b.  If this would be beyond t,
+** we back it off to t.  Only when r is less than t do we consider the
+** run long enough to consider checking.
+**
+** q addresses a pair such that the pairs at b through q already form a run.
+** Often, q will equal b, indicating we only are sure of the pair itself.
+** However, a search on the previous cycle may have revealed a longer run,
+** so q may be greater than b.
+**
+** p is used to work back from a candidate r, trying to reach q,
+** which would mean b through r would be a run.  If we discover such a run,
+** we start q at r and try to push it further towards t.
+** If b through r is NOT a run, we detect the wrong order at (p-1,p).
+** In any event, after the check (if any), we have two main cases.
+**
+** 1) Short run.  b <= q < p <= r <= t.
+**	b through q is a run (perhaps trivial)
+**	q through p are uninteresting pairs
+**	p through r is a run
+**
+** 2) Long run.  b < r <= q < t.
+**	b through q is a run (of length >= 2 * PTHRESH)
+**
+** Note that degenerate cases are not only possible, but likely.
+** For example, if the pair following b compares with opposite sense,
+** then b == q < p == r == t.
 */
-struct partition_stack_entry {
-   int left;
-   int right;
-#ifdef QSORT_ORDER_GUESS
-   int qsort_break_even;
-#endif
-};
 
-/* ******************************************************* Shorthand Macros */
 
-/* Note that these macros will be used from inside the qsort function where
-   we happen to know that the variable 'elt_size' contains the size of an
-   array element and the variable 'temp' points to enough space to hold a
-   temp element and the variable 'array' points to the array being sorted
-   and 'compare' is the pointer to the compare routine.
+static void
+dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
+{
+    int sense;
+    register gptr *b, *p, *q, *t, *p2;
+    register gptr c, *last, *r;
+    gptr *savep;
+
+    b = list1;
+    last = PINDEX(b, nmemb);
+    sense = (cmp(aTHX_ *b, *(b+1)) > 0);
+    for (p2 = list2; b < last; ) {
+	/* We just started, or just reversed sense.
+	** Set t at end of pairs with the prevailing sense.
+	*/
+	for (p = b+2, t = p; ++p < last; t = ++p) {
+	    if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
+	}
+	q = b;
+	/* Having laid out the playing field, look for long runs */
+	do {
+	    p = r = b + (2 * PTHRESH);
+	    if (r >= t) p = r = t;	/* too short to care about */
+	    else {
+		while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
+		       ((p -= 2) > q));
+		if (p <= q) {
+		    /* b through r is a (long) run.
+		    ** Extend it as far as possible.
+		    */
+		    p = q = r;
+		    while (((p += 2) < t) &&
+			   ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
+		    r = p = q + 2;	/* no simple pairs, no after-run */
+		}
+	    }
+	    if (q > b) {		/* run of greater than 2 at b */
+		savep = p;
+		p = q += 2;
+		/* pick up singleton, if possible */
+		if ((p == t) &&
+		    ((t + 1) == last) &&
+		    ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
+		    savep = r = p = q = last;
+		p2 = NEXT(p2) = p2 + (p - b);
+		if (sense) while (b < --p) {
+		    c = *b;
+		    *b++ = *p;
+		    *p = c;
+		}
+		p = savep;
+	    }
+	    while (q < p) {		/* simple pairs */
+		p2 = NEXT(p2) = p2 + 2;
+		if (sense) {
+		    c = *q++;
+		    *(q-1) = *q;
+		    *q++ = c;
+		} else q += 2;
+	    }
+	    if (((b = p) == t) && ((t+1) == last)) {
+		NEXT(p2) = p2 + 1;
+		b++;
+	    }
+	    q = r;
+	} while (b < t);
+	sense = !sense;
+    }
+    return;
+}
 
-   Also note that there are very many highly architecture specific ways
-   these might be sped up, but this is simply the most generally portable
-   code I could think of.
-*/
 
-/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
+/* Overview of bmerge variables:
+**
+** list1 and list2 address the main and auxiliary arrays.
+** They swap identities after each merge pass.
+** Base points to the original list1, so we can tell if
+** the pointers ended up where they belonged (or must be copied).
+**
+** When we are merging two lists, f1 and f2 are the next elements
+** on the respective lists.  l1 and l2 mark the end of the lists.
+** tp2 is the current location in the merged list.
+**
+** p1 records where f1 started.
+** After the merge, a new descriptor is built there.
+**
+** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
+** It is used to identify and delimit the runs.
+**
+** In the heat of determining where q, the greater of the f1/f2 elements,
+** belongs in the other list, b, t and p, represent bottom, top and probe
+** locations, respectively, in the other list.
+** They make convenient temporary pointers in other places.
 */
+
+STATIC void
+S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
+{
+    int i, run;
+    int sense;
+    register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
+    gptr *aux, *list2, *p2, *last;
+    gptr *base = list1;
+    gptr *p1;
+
+    if (nmemb <= 1) return;	/* sorted trivially */
+    New(799,list2,nmemb,gptr);	/* allocate auxilliary array */
+    aux = list2;
+    dynprep(aTHX_ list1, list2, nmemb, cmp);
+    last = PINDEX(list2, nmemb);
+    while (NEXT(list2) != last) {
+	/* More than one run remains.  Do some merging to reduce runs. */
+	l2 = p1 = list1;
+	for (tp2 = p2 = list2; p2 != last;) {
+	    /* The new first run begins where the old second list ended.
+	    ** Use the p2 ``parallel'' pointer to identify the end of the run.
+	    */
+	    f1 = l2;
+	    t = NEXT(p2);
+	    f2 = l1 = POTHER(t, list2, list1);
+	    if (t != last) t = NEXT(t);
+	    l2 = POTHER(t, list2, list1);
+	    p2 = t;
+	    while (f1 < l1 && f2 < l2) {
+		/* If head 1 is larger than head 2, find ALL the elements
+		** in list 2 strictly less than head1, write them all,
+		** then head 1.  Then compare the new heads, and repeat,
+		** until one or both lists are exhausted.
+		**
+		** In all comparisons (after establishing
+		** which head to merge) the item to merge
+		** (at pointer q) is the first operand of
+		** the comparison.  When we want to know
+		** if ``q is strictly less than the other'',
+		** we can't just do
+		**    cmp(q, other) < 0
+		** because stability demands that we treat equality
+		** as high when q comes from l2, and as low when
+		** q was from l1.  So we ask the question by doing
+		**    cmp(q, other) <= sense
+		** and make sense == 0 when equality should look low,
+		** and -1 when equality should look high.
+		*/
+
+
+		if (cmp(aTHX_ *f1, *f2) <= 0) {
+		    q = f2; b = f1; t = l1;
+		    sense = -1;
+		} else {
+		    q = f1; b = f2; t = l2;
+		    sense = 0;
+		}
+
+
+		/* ramp up
+		**
+		** Leave t at something strictly
+		** greater than q (or at the end of the list),
+		** and b at something strictly less than q.
+		*/
+		for (i = 1, run = 0 ;;) {
+		    if ((p = PINDEX(b, i)) >= t) {
+			/* off the end */
+			if (((p = PINDEX(t, -1)) > b) &&
+			    (cmp(aTHX_ *q, *p) <= sense))
+			     t = p;
+			else b = p;
+			break;
+		    } else if (cmp(aTHX_ *q, *p) <= sense) {
+			t = p;
+			break;
+		    } else b = p;
+		    if (++run >= RTHRESH) i += i;
+		}
+
+
+		/* q is known to follow b and must be inserted before t.
+		** Increment b, so the range of possibilities is [b,t).
+		** Round binary split down, to favor early appearance.
+		** Adjust b and t until q belongs just before t.
+		*/
+
+		b++;
+		while (b < t) {
+		    p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
+		    if (cmp(aTHX_ *q, *p) <= sense) {
+			t = p;
+		    } else b = p + 1;
+		}
+
+
+		/* Copy all the strictly low elements */
+
+		if (q == f1) {
+		    FROMTOUPTO(f2, tp2, t);
+		    *tp2++ = *f1++;
+		} else {
+		    FROMTOUPTO(f1, tp2, t);
+		    *tp2++ = *f2++;
+		}
+	    }
+
+
+	    /* Run out remaining list */
+	    if (f1 == l1) {
+		   if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
+	    } else              FROMTOUPTO(f1, tp2, l1);
+	    p1 = NEXT(p1) = POTHER(tp2, list2, list1);
+	}
+	t = list1;
+	list1 = list2;
+	list2 = t;
+	last = PINDEX(list2, nmemb);
+    }
+    if (base == list2) {
+	last = PINDEX(list1, nmemb);
+	FROMTOUPTO(list1, list2, last);
+    }
+    Safefree(aux);
+    return;
+}
+
+
 #ifdef PERL_OBJECT
-#define qsort_cmp(elt1, elt2) \
-   ((this->*compare)(array[elt1], array[elt2]))
-#else
-#define qsort_cmp(elt1, elt2) \
-   ((*compare)(array[elt1], array[elt2]))
+#undef this
+#define this pPerl
+#include "XSUB.h"
 #endif
 
-#ifdef QSORT_ORDER_GUESS
-#define QSORT_NOTICE_SWAP swapped++;
+
+static I32
+sortcv(pTHXo_ SV *a, SV *b)
+{
+    dTHR;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    GvSV(PL_firstgv) = a;
+    GvSV(PL_secondgv) = b;
+    PL_stack_sp = PL_stack_base;
+    PL_op = PL_sortcop;
+    CALLRUNOPS(aTHX);
+    if (PL_stack_sp != PL_stack_base + 1)
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+	LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
+static I32
+sortcv_stacked(pTHXo_ SV *a, SV *b)
+{
+    dTHR;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    AV *av;
+
+#ifdef USE_THREADS
+    av = (AV*)PL_curpad[0];
 #else
-#define QSORT_NOTICE_SWAP
+    av = GvAV(PL_defgv);
 #endif
 
-/* swaps contents of array elements elt1, elt2.
-*/
-#define qsort_swap(elt1, elt2) \
-   STMT_START { \
-      QSORT_NOTICE_SWAP \
-      temp = array[elt1]; \
-      array[elt1] = array[elt2]; \
-      array[elt2] = temp; \
-   } STMT_END
-
-/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
-   elt3 and elt3 gets elt1.
-*/
-#define qsort_rotate(elt1, elt2, elt3) \
-   STMT_START { \
-      QSORT_NOTICE_SWAP \
-      temp = array[elt1]; \
-      array[elt1] = array[elt2]; \
-      array[elt2] = array[elt3]; \
-      array[elt3] = temp; \
-   } STMT_END
+    if (AvMAX(av) < 1) {
+	SV** ary = AvALLOC(av);
+	if (AvARRAY(av) != ary) {
+	    AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+	    SvPVX(av) = (char*)ary;
+	}
+	if (AvMAX(av) < 1) {
+	    AvMAX(av) = 1;
+	    Renew(ary,2,SV*);
+	    SvPVX(av) = (char*)ary;
+	}
+    }
+    AvFILLp(av) = 1;
 
-/* ************************************************************ Debug stuff */
+    AvARRAY(av)[0] = a;
+    AvARRAY(av)[1] = b;
+    PL_stack_sp = PL_stack_base;
+    PL_op = PL_sortcop;
+    CALLRUNOPS(aTHX);
+    if (PL_stack_sp != PL_stack_base + 1)
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+	LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
 
-#ifdef QSORT_DEBUG
+static I32
+sortcv_xsub(pTHXo_ SV *a, SV *b)
+{
+    dSP;
+    I32 oldsaveix = PL_savestack_ix;
+    I32 oldscopeix = PL_scopestack_ix;
+    I32 result;
+    CV *cv=(CV*)PL_sortcop;
 
-static void
-break_here()
+    SP = PL_stack_base;
+    PUSHMARK(SP);
+    EXTEND(SP, 2);
+    *++SP = a;
+    *++SP = b;
+    PUTBACK;
+    (void)(*CvXSUB(cv))(aTHXo_ cv);
+    if (PL_stack_sp != PL_stack_base + 1)
+	Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    if (!SvNIOKp(*PL_stack_sp))
+	Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+    result = SvIV(*PL_stack_sp);
+    while (PL_scopestack_ix > oldscopeix) {
+	LEAVE;
+    }
+    leave_scope(oldsaveix);
+    return result;
+}
+
+
+static I32
+sv_ncmp(pTHXo_ SV *a, SV *b)
 {
-   return; /* good place to set a breakpoint */
+    NV nv1 = SvNV(a);
+    NV nv2 = SvNV(b);
+    return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
 }
 
-#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
+static I32
+sv_i_ncmp(pTHXo_ 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) { \
+	    if (SvAMAGIC(left)||SvAMAGIC(right))\
+		*svp = amagic_call(left, \
+				   right, \
+				   CAT2(meth,_amg), \
+				   0); \
+	  } \
+	} STMT_END
+
+static I32
+amagic_ncmp(pTHXo_ 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(aTHXo_ a, b);
+}
 
-static void
-doqsort_all_asserts(
-   void * array,
-   size_t num_elts,
-   size_t elt_size,
-   int (*compare)(const void * elt1, const void * elt2),
-   int pc_left, int pc_right, int u_left, int u_right)
-{
-   int i;
-
-   qsort_assert(pc_left <= pc_right);
-   qsort_assert(u_right < pc_left);
-   qsort_assert(pc_right < u_left);
-   for (i = u_right + 1; i < pc_left; ++i) {
-      qsort_assert(qsort_cmp(i, pc_left) < 0);
-   }
-   for (i = pc_left; i < pc_right; ++i) {
-      qsort_assert(qsort_cmp(i, pc_right) == 0);
-   }
-   for (i = pc_right + 1; i < u_left; ++i) {
-      qsort_assert(qsort_cmp(pc_right, i) < 0);
-   }
-}
-
-#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
-   doqsort_all_asserts(array, num_elts, elt_size, compare, \
-                 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
+static I32
+amagic_i_ncmp(pTHXo_ 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(aTHXo_ a, b);
+}
 
-#else
+static I32
+amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(str1,str2,scmp,&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_cmp(str1, str2);
+}
 
-#define qsort_assert(t) ((void)0)
+static I32
+amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(str1,str2,scmp,&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_cmp_locale(str1, str2);
+}
 
-#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
+static I32
+run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
+{
+    SV *datasv = FILTER_DATA(idx);
+    int filter_has_file = IoLINES(datasv);
+    GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
+    SV *filter_state = (SV *)IoTOP_GV(datasv);
+    SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
+    int len = 0;
+
+    /* I was having segfault trouble under Linux 2.2.5 after a
+       parse error occured.  (Had to hack around it with a test
+       for PL_error_count == 0.)  Solaris doesn't segfault --
+       not sure where the trouble is yet.  XXX */
+
+    if (filter_has_file) {
+	len = FILTER_READ(idx+1, buf_sv, maxlen);
+    }
 
-#endif
+    if (filter_sub && len >= 0) {
+	djSP;
+	int count;
 
-/* ****************************************************************** qsort */
+	ENTER;
+	SAVE_DEFSV;
+	SAVETMPS;
+	EXTEND(SP, 2);
 
-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
-{
-   register SV * temp;
+	DEFSV = buf_sv;
+	PUSHMARK(SP);
+	PUSHs(sv_2mortal(newSViv(maxlen)));
+	if (filter_state) {
+	    PUSHs(filter_state);
+	}
+	PUTBACK;
+	count = call_sv(filter_sub, G_SCALAR);
+	SPAGAIN;
 
-   struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
-   int next_stack_entry = 0;
+	if (count > 0) {
+	    SV *out = POPs;
+	    if (SvOK(out)) {
+		len = SvIV(out);
+	    }
+	}
 
-   int part_left;
-   int part_right;
-#ifdef QSORT_ORDER_GUESS
-   int qsort_break_even;
-   int swapped;
-#endif
+	PUTBACK;
+	FREETMPS;
+	LEAVE;
+    }
 
-   /* Make sure we actually have work to do.
-   */
-   if (num_elts <= 1) {
-      return;
-   }
-
-   /* Setup the initial partition definition and fall into the sorting loop
-   */
-   part_left = 0;
-   part_right = (int)(num_elts - 1);
-#ifdef QSORT_ORDER_GUESS
-   qsort_break_even = QSORT_BREAK_EVEN;
-#else
-#define qsort_break_even QSORT_BREAK_EVEN
-#endif
-   for ( ; ; ) {
-      if ((part_right - part_left) >= qsort_break_even) {
-         /* OK, this is gonna get hairy, so lets try to document all the
-            concepts and abbreviations and variables and what they keep
-            track of:
-
-            pc: pivot chunk - the set of array elements we accumulate in the
-                middle of the partition, all equal in value to the original
-                pivot element selected. The pc is defined by:
-
-                pc_left - the leftmost array index of the pc
-                pc_right - the rightmost array index of the pc
-
-                we start with pc_left == pc_right and only one element
-                in the pivot chunk (but it can grow during the scan).
-
-            u:  uncompared elements - the set of elements in the partition
-                we have not yet compared to the pivot value. There are two
-                uncompared sets during the scan - one to the left of the pc
-                and one to the right.
-
-                u_right - the rightmost index of the left side's uncompared set
-                u_left - the leftmost index of the right side's uncompared set
-
-                The leftmost index of the left sides's uncompared set
-                doesn't need its own variable because it is always defined
-                by the leftmost edge of the whole partition (part_left). The
-                same goes for the rightmost edge of the right partition
-                (part_right).
-
-                We know there are no uncompared elements on the left once we
-                get u_right < part_left and no uncompared elements on the
-                right once u_left > part_right. When both these conditions
-                are met, we have completed the scan of the partition.
-
-                Any elements which are between the pivot chunk and the
-                uncompared elements should be less than the pivot value on
-                the left side and greater than the pivot value on the right
-                side (in fact, the goal of the whole algorithm is to arrange
-                for that to be true and make the groups of less-than and
-                greater-then elements into new partitions to sort again).
-
-            As you marvel at the complexity of the code and wonder why it
-            has to be so confusing. Consider some of the things this level
-            of confusion brings:
-
-            Once I do a compare, I squeeze every ounce of juice out of it. I
-            never do compare calls I don't have to do, and I certainly never
-            do redundant calls.
-
-            I also never swap any elements unless I can prove there is a
-            good reason. Many sort algorithms will swap a known value with
-            an uncompared value just to get things in the right place (or
-            avoid complexity :-), but that uncompared value, once it gets
-            compared, may then have to be swapped again. A lot of the
-            complexity of this code is due to the fact that it never swaps
-            anything except compared values, and it only swaps them when the
-            compare shows they are out of position.
-         */
-         int pc_left, pc_right;
-         int u_right, u_left;
-
-         int s;
-
-         pc_left = ((part_left + part_right) / 2);
-         pc_right = pc_left;
-         u_right = pc_left - 1;
-         u_left = pc_right + 1;
-
-         /* Qsort works best when the pivot value is also the median value
-            in the partition (unfortunately you can't find the median value
-            without first sorting :-), so to give the algorithm a helping
-            hand, we pick 3 elements and sort them and use the median value
-            of that tiny set as the pivot value.
-
-            Some versions of qsort like to use the left middle and right as
-            the 3 elements to sort so they can insure the ends of the
-            partition will contain values which will stop the scan in the
-            compare loop, but when you have to call an arbitrarily complex
-            routine to do a compare, its really better to just keep track of
-            array index values to know when you hit the edge of the
-            partition and avoid the extra compare. An even better reason to
-            avoid using a compare call is the fact that you can drop off the
-            edge of the array if someone foolishly provides you with an
-            unstable compare function that doesn't always provide consistent
-            results.
-
-            So, since it is simpler for us to compare the three adjacent
-            elements in the middle of the partition, those are the ones we
-            pick here (conveniently pointed at by u_right, pc_left, and
-            u_left). The values of the left, center, and right elements
-            are refered to as l c and r in the following comments.
-         */
-
-#ifdef QSORT_ORDER_GUESS
-         swapped = 0;
-#endif
-         s = qsort_cmp(u_right, pc_left);
-         if (s < 0) {
-            /* l < c */
-            s = qsort_cmp(pc_left, u_left);
-            /* if l < c, c < r - already in order - nothing to do */
-            if (s == 0) {
-               /* l < c, c == r - already in order, pc grows */
-               ++pc_right;
-               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-            } else if (s > 0) {
-               /* l < c, c > r - need to know more */
-               s = qsort_cmp(u_right, u_left);
-               if (s < 0) {
-                  /* l < c, c > r, l < r - swap c & r to get ordered */
-                  qsort_swap(pc_left, u_left);
-                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-               } else if (s == 0) {
-                  /* l < c, c > r, l == r - swap c&r, grow pc */
-                  qsort_swap(pc_left, u_left);
-                  --pc_left;
-                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-               } else {
-                  /* l < c, c > r, l > r - make lcr into rlc to get ordered */
-                  qsort_rotate(pc_left, u_right, u_left);
-                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-               }
-            }
-         } else if (s == 0) {
-            /* l == c */
-            s = qsort_cmp(pc_left, u_left);
-            if (s < 0) {
-               /* l == c, c < r - already in order, grow pc */
-               --pc_left;
-               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-            } else if (s == 0) {
-               /* l == c, c == r - already in order, grow pc both ways */
-               --pc_left;
-               ++pc_right;
-               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-            } else {
-               /* l == c, c > r - swap l & r, grow pc */
-               qsort_swap(u_right, u_left);
-               ++pc_right;
-               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-            }
-         } else {
-            /* l > c */
-            s = qsort_cmp(pc_left, u_left);
-            if (s < 0) {
-               /* l > c, c < r - need to know more */
-               s = qsort_cmp(u_right, u_left);
-               if (s < 0) {
-                  /* l > c, c < r, l < r - swap l & c to get ordered */
-                  qsort_swap(u_right, pc_left);
-                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-               } else if (s == 0) {
-                  /* l > c, c < r, l == r - swap l & c, grow pc */
-                  qsort_swap(u_right, pc_left);
-                  ++pc_right;
-                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-               } else {
-                  /* l > c, c < r, l > r - rotate lcr into crl to order */
-                  qsort_rotate(u_right, pc_left, u_left);
-                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-               }
-            } else if (s == 0) {
-               /* l > c, c == r - swap ends, grow pc */
-               qsort_swap(u_right, u_left);
-               --pc_left;
-               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-            } else {
-               /* l > c, c > r - swap ends to get in order */
-               qsort_swap(u_right, u_left);
-               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
-            }
-         }
-         /* We now know the 3 middle elements have been compared and
-            arranged in the desired order, so we can shrink the uncompared
-            sets on both sides
-         */
-         --u_right;
-         ++u_left;
-         qsort_all_asserts(pc_left, pc_right, u_left, u_right);
-
-         /* The above massive nested if was the simple part :-). We now have
-            the middle 3 elements ordered and we need to scan through the
-            uncompared sets on either side, swapping elements that are on
-            the wrong side or simply shuffling equal elements around to get
-            all equal elements into the pivot chunk.
-         */
-
-         for ( ; ; ) {
-            int still_work_on_left;
-            int still_work_on_right;
-
-            /* Scan the uncompared values on the left. If I find a value
-               equal to the pivot value, move it over so it is adjacent to
-               the pivot chunk and expand the pivot chunk. If I find a value
-               less than the pivot value, then just leave it - its already
-               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)) {
-               s = qsort_cmp(u_right, pc_left);
-               if (s < 0) {
-                  --u_right;
-               } else if (s == 0) {
-                  --pc_left;
-                  if (pc_left != u_right) {
-                     qsort_swap(u_right, pc_left);
-                  }
-                  --u_right;
-               } else {
-                  break;
-               }
-               qsort_assert(u_right < pc_left);
-               qsort_assert(pc_left <= pc_right);
-               qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
-               qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
-            }
+    if (len <= 0) {
+	IoLINES(datasv) = 0;
+	if (filter_child_proc) {
+	    SvREFCNT_dec(filter_child_proc);
+	    IoFMT_GV(datasv) = Nullgv;
+	}
+	if (filter_state) {
+	    SvREFCNT_dec(filter_state);
+	    IoTOP_GV(datasv) = Nullgv;
+	}
+	if (filter_sub) {
+	    SvREFCNT_dec(filter_sub);
+	    IoBOTTOM_GV(datasv) = Nullgv;
+	}
+	filter_del(run_user_filter);
+    }
 
-            /* Do a mirror image scan of uncompared values on the right
-            */
-            while (still_work_on_right = (u_left <= part_right)) {
-               s = qsort_cmp(pc_right, u_left);
-               if (s < 0) {
-                  ++u_left;
-               } else if (s == 0) {
-                  ++pc_right;
-                  if (pc_right != u_left) {
-                     qsort_swap(pc_right, u_left);
-                  }
-                  ++u_left;
-               } else {
-                  break;
-               }
-               qsort_assert(u_left > pc_right);
-               qsort_assert(pc_left <= pc_right);
-               qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
-               qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
-            }
+    return len;
+}
 
-            if (still_work_on_left) {
-               /* I know I have a value on the left side which needs to be
-                  on the right side, but I need to know more to decide
-                  exactly the best thing to do with it.
-               */
-               if (still_work_on_right) {
-                  /* I know I have values on both side which are out of
-                     position. This is a big win because I kill two birds
-                     with one swap (so to speak). I can advance the
-                     uncompared pointers on both sides after swapping both
-                     of them into the right place.
-                  */
-                  qsort_swap(u_right, u_left);
-                  --u_right;
-                  ++u_left;
-                  qsort_all_asserts(pc_left, pc_right, u_left, u_right);
-               } else {
-                  /* I have an out of position value on the left, but the
-                     right is fully scanned, so I "slide" the pivot chunk
-                     and any less-than values left one to make room for the
-                     greater value over on the right. If the out of position
-                     value is immediately adjacent to the pivot chunk (there
-                     are no less-than values), I can do that with a swap,
-                     otherwise, I have to rotate one of the less than values
-                     into the former position of the out of position value
-                     and the right end of the pivot chunk into the left end
-                     (got all that?).
-                  */
-                  --pc_left;
-                  if (pc_left == u_right) {
-                     qsort_swap(u_right, pc_right);
-                     qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
-                  } else {
-                     qsort_rotate(u_right, pc_left, pc_right);
-                     qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
-                  }
-                  --pc_right;
-                  --u_right;
-               }
-            } else if (still_work_on_right) {
-               /* Mirror image of complex case above: I have an out of
-                  position value on the right, but the left is fully
-                  scanned, so I need to shuffle things around to make room
-                  for the right value on the left.
-               */
-               ++pc_right;
-               if (pc_right == u_left) {
-                  qsort_swap(u_left, pc_left);
-                  qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
-               } else {
-                  qsort_rotate(pc_right, pc_left, u_left);
-                  qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
-               }
-               ++pc_left;
-               ++u_left;
-            } else {
-               /* No more scanning required on either side of partition,
-                  break out of loop and figure out next set of partitions
-               */
-               break;
-            }
-         }
-
-         /* The elements in the pivot chunk are now in the right place. They
-            will never move or be compared again. All I have to do is decide
-            what to do with the stuff to the left and right of the pivot
-            chunk.
-
-            Notes on the QSORT_ORDER_GUESS ifdef code:
-
-            1. If I just built these partitions without swapping any (or
-               very many) elements, there is a chance that the elements are
-               already ordered properly (being properly ordered will
-               certainly result in no swapping, but the converse can't be
-               proved :-).
-
-            2. A (properly written) insertion sort will run faster on
-               already ordered data than qsort will.
-
-            3. Perhaps there is some way to make a good guess about
-               switching to an insertion sort earlier than partition size 6
-               (for instance - we could save the partition size on the stack
-               and increase the size each time we find we didn't swap, thus
-               switching to insertion sort earlier for partitions with a
-               history of not swapping).
-
-            4. Naturally, if I just switch right away, it will make
-               artificial benchmarks with pure ascending (or descending)
-               data look really good, but is that a good reason in general?
-               Hard to say...
-         */
-
-#ifdef QSORT_ORDER_GUESS
-         if (swapped < 3) {
-#if QSORT_ORDER_GUESS == 1
-            qsort_break_even = (part_right - part_left) + 1;
-#endif
-#if QSORT_ORDER_GUESS == 2
-            qsort_break_even *= 2;
-#endif
-#if QSORT_ORDER_GUESS == 3
-            int prev_break = qsort_break_even;
-            qsort_break_even *= qsort_break_even;
-            if (qsort_break_even < prev_break) {
-               qsort_break_even = (part_right - part_left) + 1;
-            }
-#endif
-         } else {
-            qsort_break_even = QSORT_BREAK_EVEN;
-         }
-#endif
+#ifdef PERL_OBJECT
 
-         if (part_left < pc_left) {
-            /* There are elements on the left which need more processing.
-               Check the right as well before deciding what to do.
-            */
-            if (pc_right < part_right) {
-               /* We have two partitions to be sorted. Stack the biggest one
-                  and process the smallest one on the next iteration. This
-                  minimizes the stack height by insuring that any additional
-                  stack entries must come from the smallest partition which
-                  (because it is smallest) will have the fewest
-                  opportunities to generate additional stack entries.
-               */
-               if ((part_right - pc_right) > (pc_left - part_left)) {
-                  /* stack the right partition, process the left */
-                  partition_stack[next_stack_entry].left = pc_right + 1;
-                  partition_stack[next_stack_entry].right = part_right;
-#ifdef QSORT_ORDER_GUESS
-                  partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
-#endif
-                  part_right = pc_left - 1;
-               } else {
-                  /* stack the left partition, process the right */
-                  partition_stack[next_stack_entry].left = part_left;
-                  partition_stack[next_stack_entry].right = pc_left - 1;
-#ifdef QSORT_ORDER_GUESS
-                  partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
-#endif
-                  part_left = pc_right + 1;
-               }
-               qsort_assert(next_stack_entry < QSORT_MAX_STACK);
-               ++next_stack_entry;
-            } else {
-               /* The elements on the left are the only remaining elements
-                  that need sorting, arrange for them to be processed as the
-                  next partition.
-               */
-               part_right = pc_left - 1;
-            }
-         } else if (pc_right < part_right) {
-            /* There is only one chunk on the right to be sorted, make it
-               the new partition and loop back around.
-            */
-            part_left = pc_right + 1;
-         } else {
-            /* This whole partition wound up in the pivot chunk, so
-               we need to get a new partition off the stack.
-            */
-            if (next_stack_entry == 0) {
-               /* the stack is empty - we are done */
-               break;
-            }
-            --next_stack_entry;
-            part_left = partition_stack[next_stack_entry].left;
-            part_right = partition_stack[next_stack_entry].right;
-#ifdef QSORT_ORDER_GUESS
-            qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
-#endif
-         }
-      } else {
-         /* This partition is too small to fool with qsort complexity, just
-            do an ordinary insertion sort to minimize overhead.
-         */
-         int i;
-         /* Assume 1st element is in right place already, and start checking
-            at 2nd element to see where it should be inserted.
-         */
-         for (i = part_left + 1; i <= part_right; ++i) {
-            int j;
-            /* Scan (backwards - just in case 'i' is already in right place)
-               through the elements already sorted to see if the ith element
-               belongs ahead of one of them.
-            */
-            for (j = i - 1; j >= part_left; --j) {
-               if (qsort_cmp(i, j) >= 0) {
-                  /* i belongs right after j
-                  */
-                  break;
-               }
-            }
-            ++j;
-            if (j != i) {
-               /* Looks like we really need to move some things
-               */
-	       int k;
-	       temp = array[i];
-	       for (k = i - 1; k >= j; --k)
-		  array[k + 1] = array[k];
-               array[j] = temp;
-            }
-         }
-
-         /* That partition is now sorted, grab the next one, or get out
-            of the loop if there aren't any more.
-         */
-
-         if (next_stack_entry == 0) {
-            /* the stack is empty - we are done */
-            break;
-         }
-         --next_stack_entry;
-         part_left = partition_stack[next_stack_entry].left;
-         part_right = partition_stack[next_stack_entry].right;
-#ifdef QSORT_ORDER_GUESS
-         qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
-#endif
-      }
-   }
+static I32
+sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
+{
+    return sv_cmp_locale(str1, str2);
+}
 
-   /* Believe it or not, the array is sorted at this point! */
+static I32
+sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
+{
+    return sv_cmp(str1, str2);
 }
+
+#endif /* PERL_OBJECT */