From: Chip Salzenberg <chip@pobox.com>
Date: Tue, 9 Mar 1999 11:51:57 +0000 (-0500)
Subject: gutsupport for C++ exceptions
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=312caa8e97f1c7ee342a9895c2f0e749625b4929;p=p5sagit%2Fp5-mst-13.2.git

gutsupport for C++ exceptions
	Message-ID: <19990309115157.E7911@perlsupport.com>
	Subject: [PATCH 5.005] Flexible Exceptions

p4raw-id: //depot/perl@3386
---

diff --git a/embed.h b/embed.h
index 2386993..cabef95 100644
--- a/embed.h
+++ b/embed.h
@@ -96,6 +96,7 @@
 #define debprofdump		Perl_debprofdump
 #define debstack		Perl_debstack
 #define debstackptrs		Perl_debstackptrs
+#define default_protect		Perl_default_protect
 #define delimcpy		Perl_delimcpy
 #define deprecate		Perl_deprecate
 #define die			Perl_die
@@ -1072,6 +1073,7 @@
 #define debprofdump		CPerlObj::Perl_debprofdump
 #define debstack		CPerlObj::Perl_debstack
 #define debstackptrs		CPerlObj::Perl_debstackptrs
+#define default_protect		CPerlObj::Perl_default_protect
 #define del_he			CPerlObj::Perl_del_he
 #define del_sv			CPerlObj::Perl_del_sv
 #define del_xiv			CPerlObj::Perl_del_xiv
diff --git a/global.sym b/global.sym
index 55a8b8b..b46c106 100644
--- a/global.sym
+++ b/global.sym
@@ -87,6 +87,7 @@ debop
 debprofdump
 debstack
 debstackptrs
+default_protect
 delimcpy
 deprecate
 die
diff --git a/objXSUB.h b/objXSUB.h
index 69a891c..53ad4e2 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -502,6 +502,8 @@
 #define PL_preprocess		pPerl->PL_preprocess
 #undef  PL_profiledata
 #define PL_profiledata		pPerl->PL_profiledata
+#undef  PL_protect
+#define PL_protect		pPerl->PL_protect
 #undef  PL_reg_call_cc
 #define PL_reg_call_cc		pPerl->PL_reg_call_cc
 #undef  PL_reg_curpm
@@ -1001,6 +1003,8 @@
 #define debstack		pPerl->Perl_debstack
 #undef  debstackptrs
 #define debstackptrs		pPerl->Perl_debstackptrs
+#undef  default_protect
+#define default_protect		pPerl->Perl_default_protect
 #undef  del_he
 #define del_he			pPerl->Perl_del_he
 #undef  del_sv
diff --git a/perl.c b/perl.c
index 7c784fc..daa15cc 100644
--- a/perl.c
+++ b/perl.c
@@ -53,6 +53,11 @@ static void init_ids _((void));
 static void init_debugger _((void));
 static void init_lexer _((void));
 static void init_main_stash _((void));
+static void *perl_parse_body _((va_list args));
+static void *perl_run_body _((va_list args));
+static void *perl_call_body _((va_list args));
+static void perl_call_xbody _((OP *myop, int is_eval));
+static void *call_list_body _((va_list args));
 #ifdef USE_THREADS
 static struct perl_thread * init_main_thread _((void));
 #endif /* USE_THREADS */
@@ -145,6 +150,8 @@ perl_construct(register PerlInterpreter *sv_interp)
 	thr = init_main_thread();
 #endif /* USE_THREADS */
 
+	PL_protect = FUNC_NAME_TO_PTR(default_protect); /* for exceptions */
+
 	PL_curcop = &PL_compiling;	/* needed by ckWARN, right away */
 
 	PL_linestr = NEWSV(65,79);
@@ -202,10 +209,7 @@ perl_construct(register PerlInterpreter *sv_interp)
     init_ids();
     PL_lex_state = LEX_NOTPARSING;
 
-    PL_start_env.je_prev = NULL;
-    PL_start_env.je_ret = -1;
-    PL_start_env.je_mustcatch = TRUE;
-    PL_top_env     = &PL_start_env;
+    JMPENV_BOOTSTRAP;
     STATUS_ALL_SUCCESS;
 
     SET_NUMERIC_STANDARD();
@@ -634,16 +638,8 @@ perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **a
 #endif
 {
     dTHR;
-    register SV *sv;
-    register char *s;
-    char *scriptname = NULL;
-    VOL bool dosearch = FALSE;
-    char *validarg = "";
     I32 oldscope;
-    AV* comppadlist;
-    dJMPENV;
     int ret;
-    int fdscript = -1;
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
@@ -694,8 +690,14 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
-    JMPENV_PUSH(ret);
+    CALLPROTECT(&ret, perl_parse_body, env
+#ifndef PERL_OBJECT
+		, xsinit
+#endif
+		);
     switch (ret) {
+    case 0:
+	return 0;
     case 1:
 	STATUS_ALL_FAILURE;
 	/* FALL THROUGH */
@@ -707,13 +709,32 @@ setuid perl scripts securely.\n");
 	PL_curstash = PL_defstash;
 	if (PL_endav)
 	    call_list(oldscope, PL_endav);
-	JMPENV_POP;
 	return STATUS_NATIVE_EXPORT;
     case 3:
-	JMPENV_POP;
 	PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
 	return 1;
     }
+}
+
+STATIC void *
+perl_parse_body(va_list args)
+{
+    dTHR;
+    int argc = PL_origargc;
+    char **argv = PL_origargv;
+    char **env = va_arg(args, char**);
+    char *scriptname = NULL;
+    int fdscript = -1;
+    VOL bool dosearch = FALSE;
+    char *validarg = "";
+    AV* comppadlist;
+    register SV *sv;
+    register char *s;
+
+#ifndef PERL_OBJECT
+    typedef void (*xs_init_t)(void);
+    xs_init_t xsinit = va_arg(args, xs_init_t);
+#endif
 
     sv_setpvn(PL_linestr,"",0);
     sv = newSVpvn("",0);		/* first used for -I flags */
@@ -1028,8 +1049,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 
     ENTER;
     PL_restartop = 0;
-    JMPENV_POP;
-    return 0;
+    return NULL;
 }
 
 int
@@ -1041,7 +1061,6 @@ perl_run(PerlInterpreter *sv_interp)
 {
     dTHR;
     I32 oldscope;
-    dJMPENV;
     int ret;
 
 #ifndef PERL_OBJECT
@@ -1051,13 +1070,14 @@ perl_run(PerlInterpreter *sv_interp)
 
     oldscope = PL_scopestack_ix;
 
-    JMPENV_PUSH(ret);
+ redo_body:
+    CALLPROTECT(&ret, perl_run_body, oldscope);
     switch (ret) {
     case 1:
 	cxstack_ix = -1;		/* start context stack again */
-	break;
-    case 2:
-	/* my_exit() was called */
+	goto redo_body;
+    case 0:  /* normal completion */
+    case 2:  /* my_exit() */
 	while (PL_scopestack_ix > oldscope)
 	    LEAVE;
 	FREETMPS;
@@ -1068,19 +1088,27 @@ perl_run(PerlInterpreter *sv_interp)
 	if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
 	    dump_mstats("after execution:  ");
 #endif
-	JMPENV_POP;
 	return STATUS_NATIVE_EXPORT;
     case 3:
-	if (!PL_restartop) {
-	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
-	    FREETMPS;
-	    JMPENV_POP;
-	    return 1;
+	if (PL_restartop) {
+	    POPSTACK_TO(PL_mainstack);
+	    goto redo_body;
 	}
-	POPSTACK_TO(PL_mainstack);
-	break;
+	PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+	FREETMPS;
+	return 1;
     }
 
+    /* NOTREACHED */
+    return 0;
+}
+
+STATIC void *
+perl_run_body(va_list args)
+{
+    dTHR;
+    I32 oldscope = va_arg(args, I32);
+
     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
                     PL_sawampersand ? "Enabling" : "Omitting"));
 
@@ -1095,7 +1123,7 @@ perl_run(PerlInterpreter *sv_interp)
 	    my_exit(0);
 	}
 	if (PERLDB_SINGLE && PL_DBsingle)
-	   sv_setiv(PL_DBsingle, 1); 
+	    sv_setiv(PL_DBsingle, 1); 
 	if (PL_initav)
 	    call_list(oldscope, PL_initav);
     }
@@ -1113,9 +1141,7 @@ perl_run(PerlInterpreter *sv_interp)
 	CALLRUNOPS();
     }
 
-    my_exit(0);
-    /* NOTREACHED */
-    return 0;
+    return NULL;
 }
 
 SV*
@@ -1232,7 +1258,6 @@ perl_call_sv(SV *sv, I32 flags)
     I32 retval;
     I32 oldscope;
     bool oldcatch = CATCH_GET;
-    dJMPENV;
     int ret;
     OP* oldop = PL_op;
 
@@ -1265,7 +1290,13 @@ perl_call_sv(SV *sv, I32 flags)
 	  && !(flags & G_NODEBUG))
 	PL_op->op_private |= OPpENTERSUB_DB;
 
-    if (flags & G_EVAL) {
+    if (!(flags & G_EVAL)) {
+	CATCH_SET(TRUE);
+	perl_call_xbody((OP*)&myop, FALSE);
+	retval = PL_stack_sp - (PL_stack_base + oldmark);
+	CATCH_SET(FALSE);
+    }
+    else {
 	cLOGOP->op_other = PL_op;
 	PL_markstack_ptr--;
 	/* we're trying to emulate pp_entertry() here */
@@ -1289,9 +1320,13 @@ perl_call_sv(SV *sv, I32 flags)
 	}
 	PL_markstack_ptr++;
 
-	JMPENV_PUSH(ret);
+  redo_body:
+	CALLPROTECT(&ret, perl_call_body, (OP*)&myop, FALSE);
 	switch (ret) {
 	case 0:
+	    retval = PL_stack_sp - (PL_stack_base + oldmark);
+	    if (!(flags & G_KEEPERR))
+		sv_setpv(ERRSV,"");
 	    break;
 	case 1:
 	    STATUS_ALL_FAILURE;
@@ -1300,7 +1335,6 @@ perl_call_sv(SV *sv, I32 flags)
 	    /* my_exit() was called */
 	    PL_curstash = PL_defstash;
 	    FREETMPS;
-	    JMPENV_POP;
 	    if (PL_statusvalue)
 		croak("Callback called exit");
 	    my_exit_jump();
@@ -1309,7 +1343,7 @@ perl_call_sv(SV *sv, I32 flags)
 	    if (PL_restartop) {
 		PL_op = PL_restartop;
 		PL_restartop = 0;
-		break;
+		goto redo_body;
 	    }
 	    PL_stack_sp = PL_stack_base + oldmark;
 	    if (flags & G_ARRAY)
@@ -1318,22 +1352,9 @@ perl_call_sv(SV *sv, I32 flags)
 		retval = 1;
 		*++PL_stack_sp = &PL_sv_undef;
 	    }
-	    goto cleanup;
+	    break;
 	}
-    }
-    else
-	CATCH_SET(TRUE);
 
-    if (PL_op == (OP*)&myop)
-	PL_op = pp_entersub(ARGS);
-    if (PL_op)
-	CALLRUNOPS();
-    retval = PL_stack_sp - (PL_stack_base + oldmark);
-    if ((flags & G_EVAL) && !(flags & G_KEEPERR))
-	sv_setpv(ERRSV,"");
-
-  cleanup:
-    if (flags & G_EVAL) {
 	if (PL_scopestack_ix > oldscope) {
 	    SV **newsp;
 	    PMOP *newpm;
@@ -1347,10 +1368,7 @@ perl_call_sv(SV *sv, I32 flags)
 	    PL_curpm = newpm;
 	    LEAVE;
 	}
-	JMPENV_POP;
     }
-    else
-	CATCH_SET(oldcatch);
 
     if (flags & G_DISCARD) {
 	PL_stack_sp = PL_stack_base + oldmark;
@@ -1362,6 +1380,31 @@ perl_call_sv(SV *sv, I32 flags)
     return retval;
 }
 
+STATIC void *
+perl_call_body(va_list args)
+{
+    OP *myop = va_arg(args, OP*);
+    int is_eval = va_arg(args, int);
+
+    perl_call_xbody(myop, is_eval);
+    return NULL;
+}
+
+STATIC void
+perl_call_xbody(OP *myop, int is_eval)
+{
+    dTHR;
+
+    if (PL_op == myop) {
+	if (is_eval)
+	    PL_op = pp_entereval(ARGS);
+	else
+	    PL_op = pp_entersub(ARGS);
+    }
+    if (PL_op)
+	CALLRUNOPS();
+}
+
 /* Eval a string. The G_EVAL flag is always assumed. */
 
 I32
@@ -1374,7 +1417,6 @@ perl_eval_sv(SV *sv, I32 flags)
     I32 oldmark = SP - PL_stack_base;
     I32 retval;
     I32 oldscope;
-    dJMPENV;
     int ret;
     OP* oldop = PL_op;
 
@@ -1400,9 +1442,13 @@ perl_eval_sv(SV *sv, I32 flags)
     if (flags & G_KEEPERR)
 	myop.op_flags |= OPf_SPECIAL;
 
-    JMPENV_PUSH(ret);
+ redo_body:
+    CALLPROTECT(&ret, perl_call_body, (OP*)&myop, TRUE);
     switch (ret) {
     case 0:
+	retval = PL_stack_sp - (PL_stack_base + oldmark);
+	if (!(flags & G_KEEPERR))
+	    sv_setpv(ERRSV,"");
 	break;
     case 1:
 	STATUS_ALL_FAILURE;
@@ -1411,7 +1457,6 @@ perl_eval_sv(SV *sv, I32 flags)
 	/* my_exit() was called */
 	PL_curstash = PL_defstash;
 	FREETMPS;
-	JMPENV_POP;
 	if (PL_statusvalue)
 	    croak("Callback called exit");
 	my_exit_jump();
@@ -1420,7 +1465,7 @@ perl_eval_sv(SV *sv, I32 flags)
 	if (PL_restartop) {
 	    PL_op = PL_restartop;
 	    PL_restartop = 0;
-	    break;
+	    goto redo_body;
 	}
 	PL_stack_sp = PL_stack_base + oldmark;
 	if (flags & G_ARRAY)
@@ -1429,19 +1474,9 @@ perl_eval_sv(SV *sv, I32 flags)
 	    retval = 1;
 	    *++PL_stack_sp = &PL_sv_undef;
 	}
-	goto cleanup;
+	break;
     }
 
-    if (PL_op == (OP*)&myop)
-	PL_op = pp_entereval(ARGS);
-    if (PL_op)
-	CALLRUNOPS();
-    retval = PL_stack_sp - (PL_stack_base + oldmark);
-    if (!(flags & G_KEEPERR))
-	sv_setpv(ERRSV,"");
-
-  cleanup:
-    JMPENV_POP;
     if (flags & G_DISCARD) {
 	PL_stack_sp = PL_stack_base + oldmark;
 	retval = 0;
@@ -2961,35 +2996,29 @@ void
 call_list(I32 oldscope, AV *paramList)
 {
     dTHR;
+    SV *atsv = ERRSV;
     line_t oldline = PL_curcop->cop_line;
+    CV *cv;
     STRLEN len;
-    dJMPENV;
     int ret;
 
     while (AvFILL(paramList) >= 0) {
-	CV *cv = (CV*)av_shift(paramList);
-
+	cv = (CV*)av_shift(paramList);
 	SAVEFREESV(cv);
-
-	JMPENV_PUSH(ret);
+	CALLPROTECT(&ret, call_list_body, cv);
 	switch (ret) {
-	case 0: {
-		SV* atsv = ERRSV;
-		PUSHMARK(PL_stack_sp);
-		perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
-		(void)SvPV(atsv, len);
-		if (len) {
-		    JMPENV_POP;
-		    PL_curcop = &PL_compiling;
-		    PL_curcop->cop_line = oldline;
-		    if (paramList == PL_beginav)
-			sv_catpv(atsv, "BEGIN failed--compilation aborted");
-		    else
-			sv_catpv(atsv, "END failed--cleanup aborted");
-		    while (PL_scopestack_ix > oldscope)
-			LEAVE;
-		    croak("%s", SvPVX(atsv));
-		}
+	case 0:
+	    (void)SvPV(atsv, len);
+	    if (len) {
+		PL_curcop = &PL_compiling;
+		PL_curcop->cop_line = oldline;
+		if (paramList == PL_beginav)
+		    sv_catpv(atsv, "BEGIN failed--compilation aborted");
+		else
+		    sv_catpv(atsv, "END failed--cleanup aborted");
+		while (PL_scopestack_ix > oldscope)
+		    LEAVE;
+		croak("%s", SvPVX(atsv));
 	    }
 	    break;
 	case 1:
@@ -3003,7 +3032,6 @@ call_list(I32 oldscope, AV *paramList)
 	    PL_curstash = PL_defstash;
 	    if (PL_endav)
 		call_list(oldscope, PL_endav);
-	    JMPENV_POP;
 	    PL_curcop = &PL_compiling;
 	    PL_curcop->cop_line = oldline;
 	    if (PL_statusvalue) {
@@ -3015,20 +3043,29 @@ call_list(I32 oldscope, AV *paramList)
 	    my_exit_jump();
 	    /* NOTREACHED */
 	case 3:
-	    if (!PL_restartop) {
-		PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
-		FREETMPS;
-		break;
+	    if (PL_restartop) {
+		PL_curcop = &PL_compiling;
+		PL_curcop->cop_line = oldline;
+		JMPENV_JUMP(3);
 	    }
-	    JMPENV_POP;
-	    PL_curcop = &PL_compiling;
-	    PL_curcop->cop_line = oldline;
-	    JMPENV_JUMP(3);
+	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+	    FREETMPS;
+	    break;
 	}
-	JMPENV_POP;
     }
 }
 
+STATIC void *
+call_list_body(va_list args)
+{
+    dTHR;
+    CV *cv = va_arg(args, CV*);
+
+    PUSHMARK(PL_stack_sp);
+    perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
+    return NULL;
+}
+
 void
 my_exit(U32 status)
 {
diff --git a/perl.h b/perl.h
index 0acc213..14e891c 100644
--- a/perl.h
+++ b/perl.h
@@ -107,9 +107,7 @@ class CPerlObj;
 #define PERL_OBJECT_THIS this
 #define _PERL_OBJECT_THIS ,this
 #define PERL_OBJECT_THIS_ this,
-#define CALLRUNOPS (this->*PL_runops)
-#define CALLREGCOMP (this->*PL_regcompp)
-#define CALLREGEXEC (this->*PL_regexecp)
+#define CALL_FPTR(fptr) (this->*fptr)
 
 #else /* !PERL_OBJECT */
 
@@ -123,12 +121,15 @@ class CPerlObj;
 #define PERL_OBJECT_THIS
 #define _PERL_OBJECT_THIS
 #define PERL_OBJECT_THIS_
-#define CALLRUNOPS (*PL_runops)
-#define CALLREGCOMP (*PL_regcompp)
-#define CALLREGEXEC (*PL_regexecp)
+#define CALL_FPTR(fptr) (*fptr)
 
 #endif /* PERL_OBJECT */
 
+#define CALLRUNOPS  CALL_FPTR(PL_runops)
+#define CALLREGCOMP CALL_FPTR(PL_regcompp)
+#define CALLREGEXEC CALL_FPTR(PL_regexecp)
+#define CALLPROTECT CALL_FPTR(PL_protect)
+
 #define VOIDUSED 1
 #include "config.h"
 
diff --git a/pp_ctl.c b/pp_ctl.c
index ec98233..9d6d063 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -29,6 +29,7 @@
 #define CALLOP this->*PL_op
 #else
 #define CALLOP *PL_op
+static void *docatch_body _((void *o));
 static OP *docatch _((OP *o));
 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
 static void doparseform _((SV *sv));
@@ -2491,38 +2492,41 @@ save_lines(AV *array, SV *sv)
     }
 }
 
+STATIC void *
+docatch_body(va_list args)
+{
+    CALLRUNOPS();
+    return NULL;
+}
+
 STATIC OP *
 docatch(OP *o)
 {
     dTHR;
     int ret;
     OP *oldop = PL_op;
-    dJMPENV;
 
-    PL_op = o;
 #ifdef DEBUGGING
     assert(CATCH_GET == TRUE);
-    DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
 #endif
-    JMPENV_PUSH(ret);
+    PL_op = o;
+ redo_body:
+    CALLPROTECT(&ret, docatch_body);
     switch (ret) {
-    default:				/* topmost level handles it */
-pass_the_buck:
-	JMPENV_POP;
+    case 0:
+	break;
+    case 3:
+	if (PL_restartop) {
+	    PL_op = PL_restartop;
+	    PL_restartop = 0;
+	    goto redo_body;
+	}
+	/* FALL THROUGH */
+    default:
 	PL_op = oldop;
 	JMPENV_JUMP(ret);
 	/* NOTREACHED */
-    case 3:
-	if (!PL_restartop)
-	    goto pass_the_buck;
-	PL_op = PL_restartop;
-	PL_restartop = 0;
-	/* FALL THROUGH */
-    case 0:
-        CALLRUNOPS();
-	break;
     }
-    JMPENV_POP;
     PL_op = oldop;
     return Nullop;
 }
diff --git a/proto.h b/proto.h
index adc4d0a..526a0ff 100644
--- a/proto.h
+++ b/proto.h
@@ -744,6 +744,12 @@ void doencodes _((SV* sv, char* s, I32 len));
 SV* refto _((SV* sv));
 U32 seed _((void));
 OP *docatch _((OP *o));
+void *docatch_body _((va_list args));
+void *perl_parse_body _((va_list args));
+void *perl_run_body _((va_list args));
+void *perl_call_body _((va_list args));
+void perl_call_xbody _((OP *myop, int is_eval));
+void *call_list_body _((va_list args));
 OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
 void doparseform _((SV *sv));
 I32 dopoptoeval _((I32 startingblock));
@@ -969,6 +975,7 @@ VIRTUAL void do_op_dump _((I32 level, PerlIO *file, OP *o));
 VIRTUAL void do_pmop_dump _((I32 level, PerlIO *file, PMOP *pm));
 VIRTUAL void do_sv_dump _((I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim));
 VIRTUAL void magic_dump _((MAGIC *mg));
+VIRTUAL void* default_protect _((int *except, protect_body_t, ...));
 VIRTUAL void reginitcolors _((void));
 VIRTUAL char* sv_2pv_nolen _((SV* sv));
 VIRTUAL char* sv_pv _((SV *sv));
diff --git a/scope.c b/scope.c
index b8d4558..6c9c427 100644
--- a/scope.c
+++ b/scope.c
@@ -15,6 +15,30 @@
 #include "EXTERN.h"
 #include "perl.h"
 
+void *
+default_protect(int *except, protect_body_t body, ...)
+{
+    dTHR;
+    dJMPENV;
+    va_list args;
+    int ex;
+    void *ret;
+
+    DEBUG_l(deb("Setting up local jumplevel %p, was %p\n",
+		&cur_env, PL_top_env));
+    JMPENV_PUSH(ex);
+    if (ex)
+	ret = NULL;
+    else {
+	va_start(args, body);
+	ret = body(args);
+	va_end(args);
+    }
+    *except = ex;
+    JMPENV_POP;
+    return ret;
+}
+
 SV**
 stack_grow(SV **sp, SV **p, int n)
 {
diff --git a/scope.h b/scope.h
index aa865bf..1502d4f 100644
--- a/scope.h
+++ b/scope.h
@@ -147,13 +147,41 @@
 
 struct jmpenv {
     struct jmpenv *	je_prev;
-    Sigjmp_buf		je_buf;		
-    int			je_ret;		/* return value of last setjmp() */
-    bool		je_mustcatch;	/* longjmp()s must be caught locally */
+    Sigjmp_buf		je_buf;		/* only for use if !je_throw */
+    int			je_ret;		/* last exception thrown */
+    bool		je_mustcatch;	/* need to call longjmp()? */
+    void		(*je_throw)(int v); /* last for bincompat */
 };
 
 typedef struct jmpenv JMPENV;
 
+/*
+ * Function that catches/throws, and its callback for the
+ *  body of protected processing.
+ */
+typedef void *(CPERLscope(*protect_body_t)) _((va_list args));
+typedef void *(CPERLscope(*protect_proc_t))
+			_((int *except, protect_body_t, ...));
+
+/*
+ * How to build the first jmpenv.
+ *
+ * top_env needs to be non-zero. It points to an area
+ * in which longjmp() stuff is stored, as C callstack
+ * info there at least is thread specific this has to
+ * be per-thread. Otherwise a 'die' in a thread gives
+ * that thread the C stack of last thread to do an eval {}!
+ */
+
+#define JMPENV_BOOTSTRAP \
+    STMT_START {				\
+	PL_start_env.je_prev = NULL;		\
+	PL_start_env.je_throw = NULL;		\
+	PL_start_env.je_ret = -1;		\
+	PL_start_env.je_mustcatch = TRUE;	\
+	PL_top_env = &PL_start_env;		\
+    } STMT_END
+
 #ifdef OP_IN_REGISTER
 #define OP_REG_TO_MEM	PL_opsave = op
 #define OP_MEM_TO_REG	op = PL_opsave
@@ -162,30 +190,82 @@ typedef struct jmpenv JMPENV;
 #define OP_MEM_TO_REG	NOOP
 #endif
 
+/*
+ * These exception-handling macros are split up to
+ * ease integration with C++ exceptions.
+ *
+ * To use C++ try+catch to catch Perl exceptions, an extension author
+ * needs to first write an extern "C" function to throw an appropriate
+ * exception object; typically it will be or contain an integer,
+ * because Perl's internals use integers to track exception types:
+ *    extern "C" { static void thrower(int i) { throw i; } }
+ *
+ * Then (as shown below) the author needs to use, not the simple
+ * JMPENV_PUSH, but several of its constitutent macros, to arrange for
+ * the Perl internals to call thrower() rather than longjmp() to
+ * report exceptions:
+ *
+ *    dJMPENV;
+ *    JMPENV_PUSH_INIT(thrower);
+ *    try {
+ *        ... stuff that may throw exceptions ...
+ *    }
+ *    catch (int why) {  // or whatever matches thrower()
+ *        JMPENV_POST_CATCH;
+ *        EXCEPT_SET(why);
+ *        switch (why) {
+ *          ... // handle various Perl exception codes
+ *        }
+ *    }
+ *    JMPENV_POP;  // don't forget this!
+ */
+
 #define dJMPENV		JMPENV cur_env
-#define JMPENV_PUSH(v) \
+
+#define JMPENV_PUSH_INIT(THROWFUNC) \
     STMT_START {					\
+	cur_env.je_throw = (THROWFUNC);			\
+	cur_env.je_ret = -1;				\
+	cur_env.je_mustcatch = FALSE;			\
 	cur_env.je_prev = PL_top_env;			\
+	PL_top_env = &cur_env;				\
 	OP_REG_TO_MEM;					\
-	cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1);	\
+    } STMT_END
+#define JMPENV_POST_CATCH \
+    STMT_START {					\
 	OP_MEM_TO_REG;					\
 	PL_top_env = &cur_env;				\
-	cur_env.je_mustcatch = FALSE;			\
-	(v) = cur_env.je_ret;				\
     } STMT_END
+
+#define JMPENV_PUSH(v) \
+    STMT_START {					\
+	JMPENV_PUSH_INIT(NULL);				\
+	EXCEPT_SET(PerlProc_setjmp(cur_env.je_buf, 1));	\
+	JMPENV_POST_CATCH;				\
+	(v) = EXCEPT_GET;				\
+    } STMT_END
+
 #define JMPENV_POP \
     STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+
 #define JMPENV_JUMP(v) \
     STMT_START {						\
 	OP_REG_TO_MEM;						\
-	if (PL_top_env->je_prev)					\
-	    PerlProc_longjmp(PL_top_env->je_buf, (v));			\
+	if (PL_top_env->je_prev) {				\
+	    if (PL_top_env->je_throw)				\
+		PL_top_env->je_throw(v);			\
+	    else						\
+		PerlProc_longjmp(PL_top_env->je_buf, (v));	\
+	}							\
 	if ((v) == 2)						\
-	    PerlProc_exit(STATUS_NATIVE_EXPORT);				\
+	    PerlProc_exit(STATUS_NATIVE_EXPORT);		\
 	PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");	\
-	PerlProc_exit(1);						\
+	PerlProc_exit(1);					\
     } STMT_END
-   
+
+#define EXCEPT_GET	(cur_env.je_ret)
+#define EXCEPT_SET(v)	(cur_env.je_ret = (v))
+
 #define CATCH_GET	(PL_top_env->je_mustcatch)
 #define CATCH_SET(v)	(PL_top_env->je_mustcatch = (v))
    
diff --git a/thrdvar.h b/thrdvar.h
index 69f17fb..7fae131 100644
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -93,8 +93,10 @@ PERLVAR(Tlocalizing,	int)		/* are we processing a local() list? */
 PERLVAR(Tcurstack,	AV *)		/* THE STACK */
 PERLVAR(Tcurstackinfo,	PERL_SI *)	/* current stack + context */
 PERLVAR(Tmainstack,	AV *)		/* the stack when nothing funny is happening */
+
 PERLVAR(Ttop_env,	JMPENV *)	/* ptr. to current sigjmp() environment */
 PERLVAR(Tstart_env,	JMPENV)		/* empty startup sigjmp() environment */
+PERLVARI(Tprotect,	protect_proc_t,	FUNC_NAME_TO_PTR(default_protect))
 
 /* statics "owned" by various functions */
 PERLVAR(Tav_fetch_sv,	SV *)		/* owned by av_fetch() */
diff --git a/util.c b/util.c
index 56199d2..ba77288 100644
--- a/util.c
+++ b/util.c
@@ -2932,6 +2932,8 @@ new_struct_thread(struct perl_thread *t)
     Zero(thr, 1, struct perl_thread);
 #endif
 
+    PL_protect = FUNC_NAME_TO_PTR(default_protect);
+
     thr->oursv = sv;
     init_stacks(ARGS);
 
@@ -2975,6 +2977,8 @@ new_struct_thread(struct perl_thread *t)
     /* parent thread's data needs to be locked while we make copy */
     MUTEX_LOCK(&t->mutex);
 
+    PL_protect = t->Tprotect;
+
     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
     PL_defstash = t->Tdefstash;   /* XXX maybe these should */
     PL_curstash = t->Tcurstash;   /* always be set to main? */