added patch, fixed typo, reworked documentation

	Message-Id: <H00000e500071aa3@MHS>
	Subject: [PATCH 5.004_66] JMPENV!

p4raw-id: //depot/perl@1135

17 files changed, 824 insertions, 492 deletions

diff --git a/ObjXSub.h b/ObjXSub.h
index 605ef1c471..5bdac21a6f 100644
--- a/ObjXSub.h
+++ b/ObjXSub.h
@@ -650,6 +650,8 @@
 #define top_env			pPerl->Perl_top_env
 #undef  toptarget
 #define toptarget		pPerl->Perl_toptarget
+#undef  tryblock_function
+#define tryblock_function	pPerl->Perl_tryblock_function
 #undef  uid
 #define uid			pPerl->Perl_uid
 #undef  unsafe
@@ -1065,6 +1067,8 @@
 #define ingroup             pPerl->Perl_ingroup
 #undef  init_stacks
 #define init_stacks         pPerl->Perl_init_stacks
+#undef  install_tryblock_method
+#define install_tryblock_method	pPerl->Perl_install_tryblock_method
 #undef  instr
 #define instr               pPerl->Perl_instr
 #undef  intro_my
diff --git a/cc_runtime.h b/cc_runtime.h
index fe830c0bde..7d28ff5bb9 100644
--- a/cc_runtime.h
+++ b/cc_runtime.h
@@ -38,22 +38,22 @@
 /* Anyone using eval "" deserves this mess */
 #define PP_EVAL(ppaddr, nxt) do {		\
 	dJMPENV;				\
-	int ret;				\
+	int jmpstat;				\
 	PUTBACK;				\
-	JMPENV_PUSH(ret);			\
-	switch (ret) {				\
-	case 0:					\
+	JMPENV_PUSH(jmpstat);			\
+	switch (jmpstat) {			\
+	case JMP_NORMAL:			\
 	    op = ppaddr(ARGS);			\
 	    retstack[retstack_ix - 1] = Nullop;	\
 	    if (op != nxt) runops();		\
 	    JMPENV_POP;				\
 	    break;				\
-	case 1: JMPENV_POP; JMPENV_JUMP(1);	\
-	case 2: JMPENV_POP; JMPENV_JUMP(2);	\
-	case 3:					\
+	case JMP_ABNORMAL: JMPENV_POP; JMPENV_JUMP(JMP_ABNORMAL);	\
+	case JMP_MYEXIT: JMPENV_POP; JMPENV_JUMP(JMP_MYEXIT);	\
+	case JMP_EXCEPTION:					\
 	    JMPENV_POP;				\
 	    if (restartop != nxt)		\
-		JMPENV_JUMP(3);			\
+		JMPENV_JUMP(JMP_EXCEPTION);			\
 	}					\
 	op = nxt;				\
 	SPAGAIN;				\
@@ -64,8 +64,8 @@
 	int ret;				\
 	JMPENV_PUSH(ret);			\
 	switch (ret) {				\
-	case 1: JMPENV_POP; JMPENV_JUMP(1);	\
-	case 2: JMPENV_POP; JMPENV_JUMP(2);	\
-	case 3: JMPENV_POP; SPAGAIN; goto label;\
+	case JMP_ABNORMAL: JMPENV_POP; JMPENV_JUMP(JMP_ABNORMAL);	\
+	case JMP_MYEXIT: JMPENV_POP; JMPENV_JUMP(JMP_MYEXIT);	\
+	case JMP_EXCEPTION: JMPENV_POP; SPAGAIN; goto label;\
 	}					\
     } while (0)
diff --git a/embed.h b/embed.h
index c5b537ea94..bca4108540 100644
--- a/embed.h
+++ b/embed.h
@@ -260,6 +260,7 @@
 #define ingroup			Perl_ingroup
 #define init_stacks		Perl_init_stacks
 #define init_thread_intern	Perl_init_thread_intern
+#define install_tryblock_method	Perl_install_tryblock_method
 #define instr			Perl_instr
 #define intro_my		Perl_intro_my
 #define intuit_more		Perl_intuit_more
diff --git a/embedvar.h b/embedvar.h
index 2e64829b6c..244176798a 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -239,6 +239,7 @@
 #define tainting		(curinterp->Itainting)
 #define threadnum		(curinterp->Ithreadnum)
 #define thrsv			(curinterp->Ithrsv)
+#define tryblock_function	(curinterp->Itryblock_function)
 #define unsafe			(curinterp->Iunsafe)
 #define warnhook		(curinterp->Iwarnhook)
 
@@ -403,6 +404,7 @@
 #define Itainting		tainting
 #define Ithreadnum		threadnum
 #define Ithrsv			thrsv
+#define Itryblock_function	tryblock_function
 #define Iunsafe			unsafe
 #define Iwarnhook		warnhook
 
@@ -629,6 +631,7 @@
 #define tainting		Perl_tainting
 #define threadnum		Perl_threadnum
 #define thrsv			Perl_thrsv
+#define tryblock_function	Perl_tryblock_function
 #define unsafe			Perl_unsafe
 #define warnhook		Perl_warnhook
 
diff --git a/global.sym b/global.sym
index 9b3308f42d..a455804426 100644
--- a/global.sym
+++ b/global.sym
@@ -367,6 +367,7 @@ ibcmp
 ibcmp_locale
 ingroup
 init_stacks
+install_tryblock_method
 instr
 intro_my
 intuit_more
diff --git a/interp.sym b/interp.sym
index 7bbb11e5fc..344af2c5f0 100644
--- a/interp.sym
+++ b/interp.sym
@@ -186,5 +186,6 @@ tmps_max
 tmps_stack
 top_env
 toptarget
+tryblock_function
 unsafe
 warnhook
diff --git a/intrpvar.h b/intrpvar.h
index 74c914bb29..9f5f41b32b 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -152,6 +152,8 @@ PERLVAR(Iors,		char *)		/* $\ */
 PERLVAR(Iorslen,	STRLEN)		
 PERLVAR(Iofmt,		char *)		/* $# */
 
+PERLVAR(Itryblock_function,	tryblock_f)	/* see scope.h */
+
 /* interpreter atexit processing */
 PERLVARI(Iexitlist,	PerlExitListEntry *, NULL)	/* list of exit functions */
 PERLVARI(Iexitlistlen,	I32, 0)				/* length of same */
diff --git a/objpp.h b/objpp.h
index 757a65b8ee..ba192d2cf1 100644
--- a/objpp.h
+++ b/objpp.h
@@ -513,6 +513,8 @@
 #define init_postdump_symbols  CPerlObj::init_postdump_symbols
 #undef  init_stacks
 #define init_stacks       CPerlObj::Perl_init_stacks
+#undef  install_tryblock_method
+#define install_tryblock_method	CPerlObj::Perl_install_tryblock_method
 #undef  intro_my
 #define intro_my          CPerlObj::Perl_intro_my
 #undef  nuke_stacks
diff --git a/perl.c b/perl.c
index 7b76edf996..a119a45acc 100644
--- a/perl.c
+++ b/perl.c
@@ -214,10 +214,8 @@ perl_construct(register PerlInterpreter *sv_interp)
     init_ids();
     lex_state = LEX_NOTPARSING;
 
-    start_env.je_prev = NULL;
-    start_env.je_ret = -1;
-    start_env.je_mustcatch = TRUE;
-    top_env     = &start_env;
+    install_tryblock_method(0);     /* default to set/longjmp style tryblock */
+    JMPENV_TOPINIT(start_env);
     STATUS_ALL_SUCCESS;
 
     SET_NUMERIC_STANDARD();
@@ -610,6 +608,17 @@ perl_atexit(void (*fn) (void *), void *ptr)
     ++exitlistlen;
 }
 
+struct try_parse_locals {
+    void (*xsinit)();
+    int argc;
+    char **argv;
+    char **env;
+    I32 oldscope;
+    int ret;
+};
+typedef struct try_parse_locals TRY_PARSE_LOCALS;
+static TRYVTBL PerlParseVtbl;
+
 int
 #ifdef PERL_OBJECT
 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
@@ -618,16 +627,11 @@ 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;
+    TRY_PARSE_LOCALS locals;
+    locals.xsinit = xsinit;
+    locals.argc = argc;
+    locals.argv = argv;
+    locals.env = env;
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
@@ -675,334 +679,19 @@ setuid perl scripts securely.\n");
     main_cv = Nullcv;
 
     time(&basetime);
-    oldscope = scopestack_ix;
-
-    JMPENV_PUSH(ret);
-    switch (ret) {
-    case 1:
-	STATUS_ALL_FAILURE;
-	/* FALL THROUGH */
-    case 2:
-	/* my_exit() was called */
-	while (scopestack_ix > oldscope)
-	    LEAVE;
-	FREETMPS;
-	curstash = defstash;
-	if (endav)
-	    call_list(oldscope, endav);
-	JMPENV_POP;
-	return STATUS_NATIVE_EXPORT;
-    case 3:
-	JMPENV_POP;
-	PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
-	return 1;
-    }
-
-    sv_setpvn(linestr,"",0);
-    sv = newSVpv("",0);		/* first used for -I flags */
-    SAVEFREESV(sv);
-    init_main_stash();
-
-    for (argc--,argv++; argc > 0; argc--,argv++) {
-	if (argv[0][0] != '-' || !argv[0][1])
-	    break;
-#ifdef DOSUID
-    if (*validarg)
-	validarg = " PHOOEY ";
-    else
-	validarg = argv[0];
-#endif
-	s = argv[0]+1;
-      reswitch:
-	switch (*s) {
-	case ' ':
-	case '0':
-	case 'F':
-	case 'a':
-	case 'c':
-	case 'd':
-	case 'D':
-	case 'h':
-	case 'i':
-	case 'l':
-	case 'M':
-	case 'm':
-	case 'n':
-	case 'p':
-	case 's':
-	case 'u':
-	case 'U':
-	case 'v':
-	case 'w':
-	    if (s = moreswitches(s))
-		goto reswitch;
-	    break;
-
-	case 'T':
-	    tainting = TRUE;
-	    s++;
-	    goto reswitch;
-
-	case 'e':
-	    if (euid != uid || egid != gid)
-		croak("No -e allowed in setuid scripts");
-	    if (!e_script) {
-		e_script = newSVpv("",0);
-		filter_add(read_e_script, NULL);
-	    }
-	    if (*++s)
-		sv_catpv(e_script, s);
-	    else if (argv[1]) {
-		sv_catpv(e_script, argv[1]);
-		argc--,argv++;
-	    }
-	    else
-		croak("No code specified for -e");
-	    sv_catpv(e_script, "\n");
-	    break;
-
-	case 'I':	/* -I handled both here and in moreswitches() */
-	    forbid_setid("-I");
-	    if (!*++s && (s=argv[1]) != Nullch) {
-		argc--,argv++;
-	    }
-	    while (s && isSPACE(*s))
-		++s;
-	    if (s && *s) {
-		char *e, *p;
-		for (e = s; *e && !isSPACE(*e); e++) ;
-		p = savepvn(s, e-s);
-		incpush(p, TRUE);
-		sv_catpv(sv,"-I");
-		sv_catpv(sv,p);
-		sv_catpv(sv," ");
-		Safefree(p);
-	    }	/* XXX else croak? */
-	    break;
-	case 'P':
-	    forbid_setid("-P");
-	    preprocess = TRUE;
-	    s++;
-	    goto reswitch;
-	case 'S':
-	    forbid_setid("-S");
-	    dosearch = TRUE;
-	    s++;
-	    goto reswitch;
-	case 'V':
-	    if (!preambleav)
-		preambleav = newAV();
-	    av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
-	    if (*++s != ':')  {
-		Sv = newSVpv("print myconfig();",0);
-#ifdef VMS
-		sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
-#else
-		sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
-#endif
-#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
-		sv_catpv(Sv,"\"  Compile-time options:");
-#  ifdef DEBUGGING
-		sv_catpv(Sv," DEBUGGING");
-#  endif
-#  ifdef NO_EMBED
-		sv_catpv(Sv," NO_EMBED");
-#  endif
-#  ifdef MULTIPLICITY
-		sv_catpv(Sv," MULTIPLICITY");
-#  endif
-		sv_catpv(Sv,"\\n\",");
-#endif
-#if defined(LOCAL_PATCH_COUNT)
-		if (LOCAL_PATCH_COUNT > 0) {
-		    int i;
-		    sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
-		    for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
-			if (localpatches[i])
-			    sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
-		    }
-		}
-#endif
-		sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
-#ifdef __DATE__
-#  ifdef __TIME__
-		sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
-#  else
-		sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
-#  endif
-#endif
-		sv_catpv(Sv, "; \
-$\"=\"\\n    \"; \
-@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
-print \"  \\%ENV:\\n    @env\\n\" if @env; \
-print \"  \\@INC:\\n    @INC\\n\";");
-	    }
-	    else {
-		Sv = newSVpv("config_vars(qw(",0);
-		sv_catpv(Sv, ++s);
-		sv_catpv(Sv, "))");
-		s += strlen(s);
-	    }
-	    av_push(preambleav, Sv);
-	    scriptname = BIT_BUCKET;	/* don't look for script or read stdin */
-	    goto reswitch;
-	case 'x':
-	    doextract = TRUE;
-	    s++;
-	    if (*s)
-		cddir = savepv(s);
-	    break;
-	case 0:
-	    break;
-	case '-':
-	    if (!*++s || isSPACE(*s)) {
-		argc--,argv++;
-		goto switch_end;
-	    }
-	    /* catch use of gnu style long options */
-	    if (strEQ(s, "version")) {
-		s = "v";
-		goto reswitch;
-	    }
-	    if (strEQ(s, "help")) {
-		s = "h";
-		goto reswitch;
-	    }
-	    s--;
-	    /* FALL THROUGH */
-	default:
-	    croak("Unrecognized switch: -%s  (-h will show valid options)",s);
-	}
-    }
-  switch_end:
-
-    if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
-	while (s && *s) {
-	    while (isSPACE(*s))
-		s++;
-	    if (*s == '-') {
-		s++;
-		if (isSPACE(*s))
-		    continue;
-	    }
-	    if (!*s)
-		break;
-	    if (!strchr("DIMUdmw", *s))
-		croak("Illegal switch in PERL5OPT: -%c", *s);
-	    s = moreswitches(s);
-	}
-    }
-
-    if (!scriptname)
-	scriptname = argv[0];
-    if (e_script) {
-	argc++,argv--;
-	scriptname = BIT_BUCKET;	/* don't look for script or read stdin */
-    }
-    else if (scriptname == Nullch) {
-#ifdef MSDOS
-	if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
-	    moreswitches("h");
-#endif
-	scriptname = "-";
-    }
-
-    init_perllib();
-
-    open_script(scriptname,dosearch,sv,&fdscript);
-
-    validate_suid(validarg, scriptname,fdscript);
-
-    if (doextract)
-	find_beginning();
-
-    main_cv = compcv = (CV*)NEWSV(1104,0);
-    sv_upgrade((SV *)compcv, SVt_PVCV);
-    CvUNIQUE_on(compcv);
-
-    comppad = newAV();
-    av_push(comppad, Nullsv);
-    curpad = AvARRAY(comppad);
-    comppad_name = newAV();
-    comppad_name_fill = 0;
-    min_intro_pending = 0;
-    padix = 0;
-#ifdef USE_THREADS
-    av_store(comppad_name, 0, newSVpv("@_", 2));
-    curpad[0] = (SV*)newAV();
-    SvPADMY_on(curpad[0]);	/* XXX Needed? */
-    CvOWNER(compcv) = 0;
-    New(666, CvMUTEXP(compcv), 1, perl_mutex);
-    MUTEX_INIT(CvMUTEXP(compcv));
-#endif /* USE_THREADS */
-
-    comppadlist = newAV();
-    AvREAL_off(comppadlist);
-    av_store(comppadlist, 0, (SV*)comppad_name);
-    av_store(comppadlist, 1, (SV*)comppad);
-    CvPADLIST(compcv) = comppadlist;
-
-    boot_core_UNIVERSAL();
-
-    if (xsinit)
-	(*xsinit)(PERL_OBJECT_THIS);	/* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP)
-    init_os_extras();
-#endif
-
-    init_predump_symbols();
-    /* init_postdump_symbols not currently designed to be called */
-    /* more than once (ENV isn't cleared first, for example)	 */
-    /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
-    if (!do_undump)
-	init_postdump_symbols(argc,argv,env);
-
-    init_lexer();
+    locals.oldscope = scopestack_ix;
 
-    /* now parse the script */
-
-    SETERRNO(0,SS$_NORMAL);
-    error_count = 0;
-    if (yyparse() || error_count) {
-	if (minus_c)
-	    croak("%s had compilation errors.\n", origfilename);
-	else {
-	    croak("Execution of %s aborted due to compilation errors.\n",
-		origfilename);
-	}
-    }
-    curcop->cop_line = 0;
-    curstash = defstash;
-    preprocess = FALSE;
-    if (e_script) {
-	SvREFCNT_dec(e_script);
-	e_script = Nullsv;
-    }
-
-    /* now that script is parsed, we can modify record separator */
-    SvREFCNT_dec(rs);
-    rs = SvREFCNT_inc(nrs);
-    sv_setsv(perl_get_sv("/", TRUE), rs);
-    if (do_undump)
-	my_unexec();
-
-    if (dowarn)
-	gv_check(defstash);
-
-    LEAVE;
-    FREETMPS;
-
-#ifdef MYMALLOC
-    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
-	dump_mstats("after compilation:");
-#endif
-
-    ENTER;
-    restartop = 0;
-    JMPENV_POP;
-    return 0;
+    TRYBLOCK(PerlParseVtbl, locals);
+    return locals.ret;
 }
 
+struct try_run_locals {
+    I32 oldscope;
+    int ret;
+};
+typedef struct try_run_locals TRY_RUN_LOCALS;
+static TRYVTBL PerlRunVtbl;
+
 int
 #ifdef PERL_OBJECT
 CPerlObj::perl_run(void)
@@ -1010,85 +699,17 @@ CPerlObj::perl_run(void)
 perl_run(PerlInterpreter *sv_interp)
 #endif
 {
-    dSP;
-    I32 oldscope;
-    dJMPENV;
-    int ret;
+    dTHR;
+    TRY_RUN_LOCALS locals;
 
 #ifndef PERL_OBJECT
     if (!(curinterp = sv_interp))
 	return 255;
 #endif
 
-    oldscope = scopestack_ix;
-
-    JMPENV_PUSH(ret);
-    switch (ret) {
-    case 1:
-	cxstack_ix = -1;		/* start context stack again */
-	break;
-    case 2:
-	/* my_exit() was called */
-	while (scopestack_ix > oldscope)
-	    LEAVE;
-	FREETMPS;
-	curstash = defstash;
-	if (endav)
-	    call_list(oldscope, endav);
-#ifdef MYMALLOC
-	if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
-	    dump_mstats("after execution:  ");
-#endif
-	JMPENV_POP;
-	return STATUS_NATIVE_EXPORT;
-    case 3:
-	if (!restartop) {
-	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
-	    FREETMPS;
-	    JMPENV_POP;
-	    return 1;
-	}
-	POPSTACK_TO(mainstack);
-	break;
-    }
-
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
-                    sawampersand ? "Enabling" : "Omitting"));
-
-    if (!restartop) {
-	DEBUG_x(dump_all());
-	DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
-#ifdef USE_THREADS
-	DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
-			      (unsigned long) thr));
-#endif /* USE_THREADS */	
-
-	if (minus_c) {
-	    PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
-	    my_exit(0);
-	}
-	if (PERLDB_SINGLE && DBsingle)
-	   sv_setiv(DBsingle, 1); 
-	if (initav)
-	    call_list(oldscope, initav);
-    }
-
-    /* do it */
-
-    if (restartop) {
-	op = restartop;
-	restartop = 0;
-	CALLRUNOPS();
-    }
-    else if (main_start) {
-	CvDEPTH(main_cv) = 1;
-	op = main_start;
-	CALLRUNOPS();
-    }
-
-    my_exit(0);
-    /* NOTREACHED */
-    return 0;
+    locals.oldscope = scopestack_ix;
+    TRYBLOCK(PerlRunVtbl, locals);
+    return locals.ret;
 }
 
 SV*
@@ -1205,7 +826,7 @@ perl_call_sv(SV *sv, I32 flags)
     I32 oldscope;
     bool oldcatch = CATCH_GET;
     dJMPENV;
-    int ret;
+    int jmpstat;
     OP* oldop = op;
 
     if (flags & G_DISCARD) {
@@ -1261,14 +882,14 @@ perl_call_sv(SV *sv, I32 flags)
 	}
 	markstack_ptr++;
 
-	JMPENV_PUSH(ret);
-	switch (ret) {
-	case 0:
+	JMPENV_PUSH(jmpstat);
+	switch (jmpstat) {
+	case JMP_NORMAL:
 	    break;
-	case 1:
+	case JMP_ABNORMAL:
 	    STATUS_ALL_FAILURE;
 	    /* FALL THROUGH */
-	case 2:
+	case JMP_MYEXIT:
 	    /* my_exit() was called */
 	    curstash = defstash;
 	    FREETMPS;
@@ -1277,7 +898,7 @@ perl_call_sv(SV *sv, I32 flags)
 		croak("Callback called exit");
 	    my_exit_jump();
 	    /* NOTREACHED */
-	case 3:
+	case JMP_EXCEPTION:
 	    if (restartop) {
 		op = restartop;
 		restartop = 0;
@@ -1347,7 +968,7 @@ perl_eval_sv(SV *sv, I32 flags)
     I32 retval;
     I32 oldscope;
     dJMPENV;
-    int ret;
+    int jmpstat;
     OP* oldop = op;
 
     if (flags & G_DISCARD) {
@@ -1372,14 +993,14 @@ perl_eval_sv(SV *sv, I32 flags)
     if (flags & G_KEEPERR)
 	myop.op_flags |= OPf_SPECIAL;
 
-    JMPENV_PUSH(ret);
-    switch (ret) {
-    case 0:
+    JMPENV_PUSH(jmpstat);
+    switch (jmpstat) {
+    case JMP_NORMAL:
 	break;
-    case 1:
+    case JMP_ABNORMAL:
 	STATUS_ALL_FAILURE;
 	/* FALL THROUGH */
-    case 2:
+    case JMP_MYEXIT:
 	/* my_exit() was called */
 	curstash = defstash;
 	FREETMPS;
@@ -1388,7 +1009,7 @@ perl_eval_sv(SV *sv, I32 flags)
 	    croak("Callback called exit");
 	my_exit_jump();
 	/* NOTREACHED */
-    case 3:
+    case JMP_EXCEPTION:
 	if (restartop) {
 	    op = restartop;
 	    restartop = 0;
@@ -2729,16 +2350,16 @@ call_list(I32 oldscope, AV *paramList)
     line_t oldline = curcop->cop_line;
     STRLEN len;
     dJMPENV;
-    int ret;
+    int jmpstat;
 
     while (AvFILL(paramList) >= 0) {
 	CV *cv = (CV*)av_shift(paramList);
 
 	SAVEFREESV(cv);
 
-	JMPENV_PUSH(ret);
-	switch (ret) {
-	case 0: {
+	JMPENV_PUSH(jmpstat);
+	switch (jmpstat) {
+	case JMP_NORMAL: {
 		SV* atsv = ERRSV;
 		PUSHMARK(stack_sp);
 		perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
@@ -2757,10 +2378,10 @@ call_list(I32 oldscope, AV *paramList)
 		}
 	    }
 	    break;
-	case 1:
+	case JMP_ABNORMAL:
 	    STATUS_ALL_FAILURE;
 	    /* FALL THROUGH */
-	case 2:
+	case JMP_MYEXIT:
 	    /* my_exit() was called */
 	    while (scopestack_ix > oldscope)
 		LEAVE;
@@ -2779,7 +2400,7 @@ call_list(I32 oldscope, AV *paramList)
 	    }
 	    my_exit_jump();
 	    /* NOTREACHED */
-	case 3:
+	case JMP_EXCEPTION:
 	    if (!restartop) {
 		PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
 		FREETMPS;
@@ -2788,7 +2409,7 @@ call_list(I32 oldscope, AV *paramList)
 	    JMPENV_POP;
 	    curcop = &compiling;
 	    curcop->cop_line = oldline;
-	    JMPENV_JUMP(3);
+	    JMPENV_JUMP(JMP_EXCEPTION);
 	}
 	JMPENV_POP;
     }
@@ -2867,18 +2488,14 @@ my_exit_jump(void)
 	LEAVE;
     }
 
-    JMPENV_JUMP(2);
+    JMPENV_JUMP(JMP_MYEXIT);
 }
 
 
 #include "XSUB.h"
 
 static I32
-#ifdef PERL_OBJECT
-read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
-#else
-read_e_script(int idx, SV *buf_sv, int maxlen)
-#endif
+read_e_script(CPERLarg_ int idx, SV *buf_sv, int maxlen)
 {
     char *p, *nl;
     p  = SvPVX(e_script);
@@ -2891,4 +2508,461 @@ read_e_script(int idx, SV *buf_sv, int maxlen)
     return 1;
 }
 
+/******************************************* perl_parse TRYBLOCK branches */
+
+#define TRY_LOCAL(name) ((TRY_PARSE_LOCALS*)locals)->name
+
+static void
+try_parse_normal0(CPERLarg_ void *locals)
+{
+    dTHR;
+    register SV *sv;
+    register char *s;
+    char *scriptname = NULL;
+    VOL bool dosearch = FALSE;
+    char *validarg = "";
+    AV* comppadlist;
+    int fdscript = -1;
+
+    void (*xsinit)() = TRY_LOCAL(xsinit);
+    int argc = TRY_LOCAL(argc);
+    char **argv = TRY_LOCAL(argv);
+    char **env = TRY_LOCAL(env);
+
+    sv_setpvn(linestr,"",0);
+    sv = newSVpv("",0);		/* first used for -I flags */
+    SAVEFREESV(sv);
+    init_main_stash();
+
+    for (argc--,argv++; argc > 0; argc--,argv++) {
+	if (argv[0][0] != '-' || !argv[0][1])
+	    break;
+#ifdef DOSUID
+    if (*validarg)
+	validarg = " PHOOEY ";
+    else
+	validarg = argv[0];
+#endif
+	s = argv[0]+1;
+      reswitch:
+	switch (*s) {
+	case ' ':
+	case '0':
+	case 'F':
+	case 'a':
+	case 'c':
+	case 'd':
+	case 'D':
+	case 'h':
+	case 'i':
+	case 'l':
+	case 'M':
+	case 'm':
+	case 'n':
+	case 'p':
+	case 's':
+	case 'u':
+	case 'U':
+	case 'v':
+	case 'w':
+	    if (s = moreswitches(s))
+		goto reswitch;
+	    break;
+
+	case 'T':
+	    tainting = TRUE;
+	    s++;
+	    goto reswitch;
+
+	case 'e':
+	    if (euid != uid || egid != gid)
+		croak("No -e allowed in setuid scripts");
+	    if (!e_script) {
+		e_script = newSVpv("",0);
+		filter_add(read_e_script, NULL);
+	    }
+	    if (*++s)
+		sv_catpv(e_script, s);
+	    else if (argv[1]) {
+		sv_catpv(e_script, argv[1]);
+		argc--,argv++;
+	    }
+	    else
+		croak("No code specified for -e");
+	    sv_catpv(e_script, "\n");
+	    break;
 
+	case 'I':	/* -I handled both here and in moreswitches() */
+	    forbid_setid("-I");
+	    if (!*++s && (s=argv[1]) != Nullch) {
+		argc--,argv++;
+	    }
+	    while (s && isSPACE(*s))
+		++s;
+	    if (s && *s) {
+		char *e, *p;
+		for (e = s; *e && !isSPACE(*e); e++) ;
+		p = savepvn(s, e-s);
+		incpush(p, TRUE);
+		sv_catpv(sv,"-I");
+		sv_catpv(sv,p);
+		sv_catpv(sv," ");
+		Safefree(p);
+	    }	/* XXX else croak? */
+	    break;
+	case 'P':
+	    forbid_setid("-P");
+	    preprocess = TRUE;
+	    s++;
+	    goto reswitch;
+	case 'S':
+	    forbid_setid("-S");
+	    dosearch = TRUE;
+	    s++;
+	    goto reswitch;
+	case 'V':
+	    if (!preambleav)
+		preambleav = newAV();
+	    av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
+	    if (*++s != ':')  {
+		Sv = newSVpv("print myconfig();",0);
+#ifdef VMS
+		sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
+#else
+		sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
+#endif
+#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
+		sv_catpv(Sv,"\"  Compile-time options:");
+#  ifdef DEBUGGING
+		sv_catpv(Sv," DEBUGGING");
+#  endif
+#  ifdef NO_EMBED
+		sv_catpv(Sv," NO_EMBED");
+#  endif
+#  ifdef MULTIPLICITY
+		sv_catpv(Sv," MULTIPLICITY");
+#  endif
+		sv_catpv(Sv,"\\n\",");
+#endif
+#if defined(LOCAL_PATCH_COUNT)
+		if (LOCAL_PATCH_COUNT > 0) {
+		    int i;
+		    sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
+		    for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
+			if (localpatches[i])
+			    sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
+		    }
+		}
+#endif
+		sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
+#ifdef __DATE__
+#  ifdef __TIME__
+		sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
+#  else
+		sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
+#  endif
+#endif
+		sv_catpv(Sv, "; \
+$\"=\"\\n    \"; \
+@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
+print \"  \\%ENV:\\n    @env\\n\" if @env; \
+print \"  \\@INC:\\n    @INC\\n\";");
+	    }
+	    else {
+		Sv = newSVpv("config_vars(qw(",0);
+		sv_catpv(Sv, ++s);
+		sv_catpv(Sv, "))");
+		s += strlen(s);
+	    }
+	    av_push(preambleav, Sv);
+	    scriptname = BIT_BUCKET;	/* don't look for script or read stdin */
+	    goto reswitch;
+	case 'x':
+	    doextract = TRUE;
+	    s++;
+	    if (*s)
+		cddir = savepv(s);
+	    break;
+	case 0:
+	    break;
+	case '-':
+	    if (!*++s || isSPACE(*s)) {
+		argc--,argv++;
+		goto switch_end;
+	    }
+	    /* catch use of gnu style long options */
+	    if (strEQ(s, "version")) {
+		s = "v";
+		goto reswitch;
+	    }
+	    if (strEQ(s, "help")) {
+		s = "h";
+		goto reswitch;
+	    }
+	    s--;
+	    /* FALL THROUGH */
+	default:
+	    croak("Unrecognized switch: -%s  (-h will show valid options)",s);
+	}
+    }
+  switch_end:
+
+    if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
+	while (s && *s) {
+	    while (isSPACE(*s))
+		s++;
+	    if (*s == '-') {
+		s++;
+		if (isSPACE(*s))
+		    continue;
+	    }
+	    if (!*s)
+		break;
+	    if (!strchr("DIMUdmw", *s))
+		croak("Illegal switch in PERL5OPT: -%c", *s);
+	    s = moreswitches(s);
+	}
+    }
+
+    if (!scriptname)
+	scriptname = argv[0];
+    if (e_script) {
+	argc++,argv--;
+	scriptname = BIT_BUCKET;	/* don't look for script or read stdin */
+    }
+    else if (scriptname == Nullch) {
+#ifdef MSDOS
+	if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
+	    moreswitches("h");
+#endif
+	scriptname = "-";
+    }
+
+    init_perllib();
+
+    open_script(scriptname,dosearch,sv,&fdscript);
+
+    validate_suid(validarg, scriptname,fdscript);
+
+    if (doextract)
+	find_beginning();
+
+    main_cv = compcv = (CV*)NEWSV(1104,0);
+    sv_upgrade((SV *)compcv, SVt_PVCV);
+    CvUNIQUE_on(compcv);
+
+    comppad = newAV();
+    av_push(comppad, Nullsv);
+    curpad = AvARRAY(comppad);
+    comppad_name = newAV();
+    comppad_name_fill = 0;
+    min_intro_pending = 0;
+    padix = 0;
+#ifdef USE_THREADS
+    av_store(comppad_name, 0, newSVpv("@_", 2));
+    curpad[0] = (SV*)newAV();
+    SvPADMY_on(curpad[0]);	/* XXX Needed? */
+    CvOWNER(compcv) = 0;
+    New(666, CvMUTEXP(compcv), 1, perl_mutex);
+    MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
+
+    comppadlist = newAV();
+    AvREAL_off(comppadlist);
+    av_store(comppadlist, 0, (SV*)comppad_name);
+    av_store(comppadlist, 1, (SV*)comppad);
+    CvPADLIST(compcv) = comppadlist;
+
+    boot_core_UNIVERSAL();
+
+    if (xsinit)
+	(*xsinit)(PERL_OBJECT_THIS);	/* in case linked C routines want magical variables */
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
+    init_os_extras();
+#endif
+
+    init_predump_symbols();
+    /* init_postdump_symbols not currently designed to be called */
+    /* more than once (ENV isn't cleared first, for example)	 */
+    /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
+    if (!do_undump)
+	init_postdump_symbols(argc,argv,env);
+
+    init_lexer();
+
+    /* now parse the script */
+
+    SETERRNO(0,SS$_NORMAL);
+    error_count = 0;
+    if (yyparse() || error_count) {
+	if (minus_c)
+	    croak("%s had compilation errors.\n", origfilename);
+	else {
+	    croak("Execution of %s aborted due to compilation errors.\n",
+		origfilename);
+	}
+    }
+    curcop->cop_line = 0;
+    curstash = defstash;
+    preprocess = FALSE;
+    if (e_script) {
+	SvREFCNT_dec(e_script);
+	e_script = Nullsv;
+    }
+
+    /* now that script is parsed, we can modify record separator */
+    SvREFCNT_dec(rs);
+    rs = SvREFCNT_inc(nrs);
+    sv_setsv(perl_get_sv("/", TRUE), rs);
+    if (do_undump)
+	my_unexec();
+
+    if (dowarn)
+	gv_check(defstash);
+
+    LEAVE;
+    FREETMPS;
+
+#ifdef MYMALLOC
+    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+	dump_mstats("after compilation:");
+#endif
+
+    ENTER;
+    restartop = 0;
+    TRY_LOCAL(ret) = 0;
+}
+
+static void
+try_parse_exception1(CPERLarg_ void *locals)
+{
+    PerlIO_printf(PerlIO_stderr(), no_top_env);
+    TRY_LOCAL(ret) = 1;
+}
+
+static void
+try_parse_myexit0(CPERLarg_ void *locals)
+{
+    dTHR;
+    I32 oldscope = TRY_LOCAL(oldscope);
+    while (scopestack_ix > oldscope)
+	LEAVE;
+    FREETMPS;
+    curstash = defstash;
+    if (endav)
+	call_list(oldscope, endav);
+    TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
+}
+
+static void
+try_parse_abnormal0(CPERLarg_ void *locals)
+{
+    STATUS_ALL_FAILURE;
+    try_parse_myexit0(locals);
+}
+
+#undef TRY_LOCAL
+static TRYVTBL PerlParseVtbl = {
+    "perl_parse",
+    try_parse_normal0,		0,
+    try_parse_abnormal0,	0,
+    0,				try_parse_exception1,
+    try_parse_myexit0,		0,
+};
+
+/******************************************* perl_run TRYBLOCK branches */
+
+#define TRY_LOCAL(name) ((TRY_RUN_LOCALS*)locals)->name
+
+static void
+try_run_normal0(CPERLarg_ void *locals)
+{
+    dTHR;
+    I32 oldscope = TRY_LOCAL(oldscope);
+
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
+                    sawampersand ? "Enabling" : "Omitting"));
+
+    if (!restartop) {
+	DEBUG_x(dump_all());
+	DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#ifdef USE_THREADS
+	DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+			      (unsigned long) thr));
+#endif /* USE_THREADS */	
+
+	if (minus_c) {
+	    PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
+	    my_exit(0);
+	}
+	if (PERLDB_SINGLE && DBsingle)
+	   sv_setiv(DBsingle, 1); 
+	if (initav)
+	    call_list(oldscope, initav);
+    }
+
+    /* do it */
+
+    if (restartop) {
+	op = restartop;
+	restartop = 0;
+	CALLRUNOPS();
+    }
+    else if (main_start) {
+	CvDEPTH(main_cv) = 1;
+	op = main_start;
+	CALLRUNOPS();
+    }
+
+    my_exit(0);
+}
+
+static void
+try_run_abnormal0(CPERLarg_ void *locals)
+{
+    dTHR;
+    cxstack_ix = -1;		/* start context stack again */
+    try_run_normal0(locals);
+}
+
+static void
+try_run_exception0(CPERLarg_ void *locals)
+{
+    dSP;
+    if (!restartop) {
+	PerlIO_printf(PerlIO_stderr(), no_restartop);
+	FREETMPS;
+	TRY_LOCAL(ret) = 1;
+    } else {
+	POPSTACK_TO(mainstack);
+	try_run_normal0(locals);
+    }
+}
+
+static void
+try_run_myexit0(CPERLarg_ void *locals)
+{
+    dTHR;
+    I32 oldscope = TRY_LOCAL(oldscope);
+
+    while (scopestack_ix > oldscope)
+	LEAVE;
+    FREETMPS;
+    curstash = defstash;
+    if (endav)
+	call_list(oldscope, endav);
+#ifdef MYMALLOC
+    if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
+	dump_mstats("after execution:  ");
+#endif
+    TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
+}
+
+#undef TRY_LOCAL
+static TRYVTBL PerlRunVtbl = {
+    "perl_run",
+    try_run_normal0,	0,
+    try_run_abnormal0,	0,
+    try_run_exception0,	0,
+    try_run_myexit0,	0
+};
diff --git a/perl.h b/perl.h
index 60f7dd5605..b8a5cb72bd 100644
--- a/perl.h
+++ b/perl.h
@@ -104,6 +104,7 @@ class CPerlObj;
 #define STATIC
 #define CPERLscope(x) CPerlObj::x
 #define CPERLproto CPerlObj *
+#define CPERLproto_ CPERLproto,
 #define _CPERLproto ,CPERLproto
 #define CPERLarg CPerlObj *pPerl
 #define CPERLarg_ CPERLarg,
@@ -118,6 +119,7 @@ class CPerlObj;
 #define STATIC static
 #define CPERLscope(x) x
 #define CPERLproto
+#define CPERLproto_
 #define _CPERLproto
 #define CPERLarg void
 #define CPERLarg_
@@ -1638,6 +1640,10 @@ EXTCONST char no_func[]
   INIT("The %s function is unimplemented");
 EXTCONST char no_myglob[]
   INIT("\"my\" variable %s can't be in a package");
+EXTCONST char no_restartop[]
+  INIT("panic: restartop\n");
+EXTCONST char no_top_env[]
+  INIT("panic: top_env\n");
 
 #ifdef DOINIT
 EXT char *sig_name[] = { SIG_NAME };
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8dd2f823a0..e35ad46619 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1380,6 +1380,11 @@ ignored.
 (F) Your machine apparently doesn't implement ioctl(), which is pretty
 strange for a machine that supports C.
 
+=item JMPENV_JUMP(%d) is bogus
+
+(S) Either some extension is trying to raise an exception type that is not
+supported by the JMPENV API, or memory has been corrupted.  See L<perlguts>.
+
 =item junk on end of regexp
 
 (P) The regular expression parser is confused.
@@ -1915,7 +1920,9 @@ was string.
 
 =item panic: top_env
 
-(P) The compiler attempted to do a goto, or something weird like that.
+(X) An attempt was made to throw some sort of exception when there
+was no exception stack.  Either perl failed to initialize properly, or
+the JMPENV API is being misused.  See L<perlguts>.
 
 =item panic: yylex
 
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index fb52ecfcb7..dce6ca5752 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1252,6 +1252,79 @@ is being used.
 
 For a complete description of the PerlIO abstraction, consult L<perlapio>.
 
+=head2 Exception Trapping (JMPENV API)
+
+As of 5.005, the internal exception trapping mechanism is replaceable
+at run-time.
+
+For a concrete example of usage, see perl.c in the perl source
+distribution.  Only a general outline is presented here.
+
+The C<TRYBLOCK()> macro is used to set up a exception handling switch.
+C<TRYBLOCK()> takes two arguments.  The first argument is a table of
+exception handlers:
+
+  struct tryvtbl {
+    /* [0] executed before JMPENV_POP
+       [1] executed after JMPENV_POP
+           (NULL pointers are OK) */
+    char *try_context;
+    void (*try_normal    [2]) _((CPERLproto_ void*));
+    void (*try_abnormal  [2]) _((CPERLproto_ void*));
+    void (*try_exception [2]) _((CPERLproto_ void*));
+    void (*try_myexit    [2]) _((CPERLproto_ void*));
+  };
+  typedef struct tryvtbl TRYVTBL;
+
+Each of the functions correspond to the exception types that
+are currently supported.  The two functions in each array are meant
+to be run before and after the exception context is exited, respectively,
+via C<JMPENV_POP()>.
+
+The second argument to C<TRYBLOCK()> is an opaque pointer that is passed
+as a first argument to each of the handler functions.  This is usually
+a structure specific to each particular exception switch containing both
+the return value and the arguments to the handler functions.
+
+Any of the handler function pointers can be C<NULL> except for
+C<try_normal[0]>, which is the only thing executed by C<TRYBLOCK()>
+after setting up the exception context.  Any code executed by
+C<try_normal[0]> is free to throw one of the three supported exceptions
+using C<JMPENV_JUMP()>.  C<JMPENV_JUMP()> can be called with one of the
+following values:
+
+  #define JMP_ABNORMAL	1	/* shouldn't happen */
+  #define JMP_MYEXIT	2	/* exit */
+  #define JMP_EXCEPTION	3	/* die */
+
+Control then resumes at the exception switch, which calls the handler
+corresponding to the type of exception that was thrown.  More exceptions
+can be thrown while in the handler, and the process repeats until one of
+the handlers return normally.
+
+In other words, depending on how C<JMPENV_JUMP()> is called, either
+C<try_abnormal[0]>, C<try_exception[0]>, or C<try_myexit[0]> are executed.
+If C<JMPENV_JUMP()> is invoked yet again before the try handler completes
+then execution will B<restart> at the try handler which corresponds to the
+most recent C<JMPENV_JUMP()>.  Care should be taken to avoid infinite
+loops.
+
+Once the try handler[0] finishes, execution moves on to one of the try
+handlers that are run after the exception context is exited (i.e.
+handler[1]).  However, the difference between the two types of handlers
+is that exceptions raised in handlers run after exiting the exception
+context are no longer caught by the C<TRYBLOCK()>.  Of course, they may
+be caught at some outer exception trap set up for the purpose.  Therefore,
+C<JMPENV_JUMP()> at this point will not be trapped; it will jump to the
+previous C<TRYBLOCK()>.  This is useful for propagating exceptions to the
+top of the stack.
+
+WARNING: At the time of this writing, the C<CC.pm> compiler backend
+does not support exception traps that are configurable at runtime.  It
+only knows how to handle exceptions thrown with longjmp() (which is what
+the default exception mechanism in perl provides).  This will be corrected
+in a future release.
+
 =head2 Putting a C value on Perl stack
 
 A lot of opcodes (this is an elementary operation in the internal perl
diff --git a/pp_ctl.c b/pp_ctl.c
index 9b924bc0f8..ac2ddfc49d 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2015,7 +2015,7 @@ PP(pp_goto)
 
     if (top_env->je_prev) {
         restartop = retop;
-        JMPENV_JUMP(3);
+        JMPENV_JUMP(JMP_EXCEPTION);
     }
 
     RETURNOP(retop);
@@ -2110,7 +2110,7 @@ STATIC OP *
 docatch(OP *o)
 {
     dTHR;
-    int ret;
+    int jmpstat;
     OP *oldop = op;
     dJMPENV;
 
@@ -2119,14 +2119,14 @@ docatch(OP *o)
     assert(CATCH_GET == TRUE);
     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
 #endif
-    JMPENV_PUSH(ret);
-    switch (ret) {
+    JMPENV_PUSH(jmpstat);
+    switch (jmpstat) {
     default:				/* topmost level handles it */
 	JMPENV_POP;
 	op = oldop;
-	JMPENV_JUMP(ret);
+	JMPENV_JUMP(jmpstat);
 	/* NOTREACHED */
-    case 3:
+    case JMP_EXCEPTION:
 	if (!restartop) {
 	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
 	    break;
@@ -2134,7 +2134,7 @@ docatch(OP *o)
 	op = restartop;
 	restartop = 0;
 	/* FALL THROUGH */
-    case 0:
+    case JMP_NORMAL:
         CALLRUNOPS();
 	break;
     }
diff --git a/proto.h b/proto.h
index 2356e68852..4467dde0a0 100644
--- a/proto.h
+++ b/proto.h
@@ -205,6 +205,7 @@ VIRTUAL I32	ibcmp _((char* a, char* b, I32 len));
 VIRTUAL I32	ibcmp_locale _((char* a, char* b, I32 len));
 VIRTUAL I32	ingroup _((I32 testgid, I32 effective));
 VIRTUAL void	init_stacks _((ARGSproto));
+VIRTUAL void	install_tryblock_method _((tryblock_f fn));
 VIRTUAL U32	intro_my _((void));
 VIRTUAL char*	instr _((char* big, char* little));
 VIRTUAL bool	io_close _((IO* io));
diff --git a/scope.c b/scope.c
index 5958aba3f5..c0924d83f2 100644
--- a/scope.c
+++ b/scope.c
@@ -15,6 +15,17 @@
 #include "EXTERN.h"
 #include "perl.h"
 
+static void setjmp_tryblock _((CPERLarg_ TRYVTBL *vtbl, void *locals));
+    
+void
+install_tryblock_method(tryblock_f fn)
+{
+    if (fn)
+	tryblock_function = fn;
+    else
+	tryblock_function = setjmp_tryblock;
+}
+
 SV**
 stack_grow(SV **sp, SV **p, int n)
 {
@@ -906,3 +917,69 @@ cx_dump(PERL_CONTEXT *cx)
     }
 #endif	/* DEBUGGING */
 }
+
+#include "XSUB.h"
+
+/* make 'static' once JMPENV_PUSH is no longer used (see scope.h) XXX */
+void
+setjmp_jump(CPERLarg)
+{
+    dTHR;
+    PerlProc_longjmp(((SETJMPENV*)top_env)->je_buf, 1);
+}
+
+static void
+setjmp_tryblock(CPERLarg_ TRYVTBL *vtbl, void *locals)
+{
+    dTHR;
+    int jmpstat;
+    SETJMPENV je;
+    JMPENV_INIT(je, setjmp_jump);
+    PerlProc_setjmp(je.je_buf, 1);
+    JMPENV_TRY(je);
+    jmpstat = JMPENV_STAT(je);
+    switch (jmpstat) {
+    case JMP_NORMAL:
+	assert(vtbl->try_normal[0]);
+	(*vtbl->try_normal[0])(PERL_OBJECT_THIS_ locals);
+	break;
+    case JMP_EXCEPTION:
+	if (vtbl->try_exception[0])
+	    (*vtbl->try_exception[0])(PERL_OBJECT_THIS_ locals);
+	break;
+    case JMP_MYEXIT:
+	if (vtbl->try_myexit[0])
+	    (*vtbl->try_myexit[0])(PERL_OBJECT_THIS_ locals);
+	break;
+    default:
+	if (jmpstat != JMP_ABNORMAL)
+	    PerlIO_printf(PerlIO_stderr(),
+			  "JMPENV_JUMP(%d) is bogus\n", jmpstat);
+	if (vtbl->try_abnormal[0])
+	    (*vtbl->try_abnormal[0])(PERL_OBJECT_THIS_ locals);
+	break;
+    }
+    JMPENV_POP_JE(je);
+    switch (JMPENV_STAT(je)) {
+    case JMP_NORMAL:
+	if (vtbl->try_normal[1])
+	    (*vtbl->try_normal[1])(PERL_OBJECT_THIS_ locals);
+	break;
+    case JMP_EXCEPTION:
+	if (vtbl->try_exception[1])
+	    (*vtbl->try_exception[1])(PERL_OBJECT_THIS_ locals);
+	break;
+    case JMP_MYEXIT:
+	if (vtbl->try_myexit[1])
+	    (*vtbl->try_myexit[1])(PERL_OBJECT_THIS_ locals);
+	break;
+    default:
+	if (jmpstat != JMP_ABNORMAL)
+	    PerlIO_printf(PerlIO_stderr(),
+			  "JMPENV_JUMP(%d) is bogus\n", jmpstat);
+	if (vtbl->try_abnormal[1])
+	    (*vtbl->try_abnormal[1])(PERL_OBJECT_THIS_ locals);
+	break;
+    }
+}
+
diff --git a/scope.h b/scope.h
index cc349f0f7c..71703651cc 100644
--- a/scope.h
+++ b/scope.h
@@ -100,25 +100,55 @@
  * points to this initially, so top_env should always be non-null.
  *
  * Existence of a non-null top_env->je_prev implies it is valid to call
- * longjmp() at that runlevel (we make sure start_env.je_prev is always
- * null to ensure this).
+ * (*je_jump)() at that runlevel.  Always use the macros below!  They
+ * manage most of the complexity for you.
  *
  * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
  * establish a local jmpenv to handle exception traps.  Care must be taken
  * to restore the previous value of je_mustcatch before exiting the
  * stack frame iff JMPENV_PUSH was not called in that stack frame.
- * GSAR 97-03-27
+ *
+ * The support for C++ try/throw causes a small loss of flexibility.
+ * No longer is it possible to place the body of exception-protected
+ * code in the same C function as JMPENV_PUSH &etc.  Older code that
+ * does this will continue to work with set/longjmp, but cannot use
+ * C++ exceptions.
+ *
+ * GSAR  19970327
+ * JPRIT 19980613 (C++ update)
  */
 
+#define JMP_NORMAL	0
+#define JMP_ABNORMAL	1	/* shouldn't happen */
+#define JMP_MYEXIT	2	/* exit */
+#define JMP_EXCEPTION	3	/* die */
+
+/* None of the JMPENV fields should be accessed directly.
+   Please use the macros below! */
 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 */
+    int			je_stat;	/* JMP_* reason for setjmp() */
+    bool		je_mustcatch;	/* will need a new TRYBLOCK? */
+    void		(*je_jump) _((CPERLproto));
 };
-
 typedef struct jmpenv JMPENV;
 
+struct tryvtbl {
+    /* [0] executed before JMPENV_POP
+       [1] executed after JMPENV_POP
+           (NULL pointers are OK) */
+    char *try_context;
+    void (*try_normal    [2]) _((CPERLproto_ void*));
+    void (*try_abnormal  [2]) _((CPERLproto_ void*));
+    void (*try_exception [2]) _((CPERLproto_ void*));
+    void (*try_myexit    [2]) _((CPERLproto_ void*));
+};
+typedef struct tryvtbl TRYVTBL;
+
+typedef void (*tryblock_f) _((CPERLproto_ TRYVTBL *vtbl, void *locals));
+#define TRYBLOCK(mytry,vars) \
+	(*tryblock_function)(PERL_OBJECT_THIS_ &mytry, &vars)
+
 #ifdef OP_IN_REGISTER
 #define OP_REG_TO_MEM	opsave = op
 #define OP_MEM_TO_REG	op = opsave
@@ -127,30 +157,83 @@ typedef struct jmpenv JMPENV;
 #define OP_MEM_TO_REG	NOOP
 #endif
 
-#define dJMPENV		JMPENV cur_env
-#define JMPENV_PUSH(v) \
-    STMT_START {					\
-	cur_env.je_prev = top_env;			\
-	OP_REG_TO_MEM;					\
-	cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1);	\
-	OP_MEM_TO_REG;					\
-	top_env = &cur_env;				\
-	cur_env.je_mustcatch = FALSE;			\
-	(v) = cur_env.je_ret;				\
-    } STMT_END
-#define JMPENV_POP \
-    STMT_START { top_env = cur_env.je_prev; } STMT_END
+#define JMPENV_TOPINIT(top)			\
+STMT_START {					\
+    top.je_prev = NULL;				\
+    top.je_stat = JMP_ABNORMAL;			\
+    top.je_mustcatch = TRUE;			\
+    top_env = &top;				\
+} STMT_END
+
+#define JMPENV_INIT(env, jmp)			\
+STMT_START {					\
+    ((JMPENV*)&env)->je_prev = top_env;		\
+    ((JMPENV*)&env)->je_stat = JMP_NORMAL;	\
+    ((JMPENV*)&env)->je_jump = jmp;		\
+    OP_REG_TO_MEM;				\
+} STMT_END
+
+#define JMPENV_TRY(env)				\
+STMT_START {					\
+    OP_MEM_TO_REG;				\
+    ((JMPENV*)&env)->je_mustcatch = FALSE;	\
+    top_env = (JMPENV*)&env;			\
+} STMT_END
+
+#define JMPENV_POP_JE(env)			\
+STMT_START {					\
+	assert(top_env == (JMPENV*)&env);	\
+	top_env = ((JMPENV*)&env)->je_prev;	\
+} STMT_END
+
+#define JMPENV_STAT(env) ((JMPENV*)&env)->je_stat
+
 #define JMPENV_JUMP(v) \
     STMT_START {						\
+	assert((v) != JMP_NORMAL);				\
 	OP_REG_TO_MEM;						\
-	if (top_env->je_prev)					\
-	    PerlProc_longjmp(top_env->je_buf, (v));			\
-	if ((v) == 2)						\
-	    PerlProc_exit(STATUS_NATIVE_EXPORT);				\
-	PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");	\
-	PerlProc_exit(1);						\
+	if (top_env->je_prev) {					\
+	    top_env->je_stat = (v);				\
+	    (*top_env->je_jump)(PERL_OBJECT_THIS);		\
+	}							\
+	if ((v) == JMP_MYEXIT)					\
+	    PerlProc_exit(STATUS_NATIVE_EXPORT);		\
+	PerlIO_printf(PerlIO_stderr(), no_top_env);		\
+	PerlProc_exit(1);					\
     } STMT_END
    
 #define CATCH_GET	(top_env->je_mustcatch)
 #define CATCH_SET(v)	(top_env->je_mustcatch = (v))
-   
+
+
+
+/*******************************************************************
+ * JMPENV_PUSH is the old depreciated API.  See perl.c for examples
+ *  of the new API.
+ */
+
+struct setjmpenv {
+    /* move to scope.c once JMPENV_PUSH is no longer needed XXX */
+    JMPENV		je0;
+    Sigjmp_buf		je_buf;		
+};
+typedef struct setjmpenv SETJMPENV;
+
+#define dJMPENV		SETJMPENV cur_env
+
+extern void setjmp_jump();
+
+#define JMPENV_PUSH(v) \
+    STMT_START {					\
+	JMPENV_INIT(cur_env, setjmp_jump);		\
+	PerlProc_setjmp(cur_env.je_buf, 1);		\
+	JMPENV_TRY(cur_env);				\
+	(v) = JMPENV_STAT(cur_env);			\
+    } STMT_END
+
+#define JMPENV_POP				\
+STMT_START {					\
+	assert(top_env == (JMPENV*) &cur_env);	\
+	top_env = cur_env.je0.je_prev;		\
+} STMT_END
+
diff --git a/util.c b/util.c
index 2fa77408a9..f1cd3bc8f3 100644
--- a/util.c
+++ b/util.c
@@ -1307,7 +1307,7 @@ die(const char* pat, ...)
 	  thr, restartop, was_in_eval, top_env));
 #endif /* USE_THREADS */
     if ((!restartop && was_in_eval) || top_env->je_prev)
-	JMPENV_JUMP(3);
+	JMPENV_JUMP(JMP_EXCEPTION);
     return restartop;
 }
 
@@ -1355,7 +1355,7 @@ croak(const char* pat, ...)
     }
     if (in_eval) {
 	restartop = die_where(message);
-	JMPENV_JUMP(3);
+	JMPENV_JUMP(JMP_EXCEPTION);
     }
     PerlIO_puts(PerlIO_stderr(),message);
     (void)PerlIO_flush(PerlIO_stderr());
@@ -2759,10 +2759,7 @@ new_struct_thread(struct perl_thread *t)
        See comments in scope.h    
        Initialize top entry (as in perl.c for main thread)
      */
-    start_env.je_prev = NULL;
-    start_env.je_ret = -1;
-    start_env.je_mustcatch = TRUE;
-    top_env  = &start_env;
+    JMPENV_TOPINIT(start_env);
 
     in_eval = FALSE;
     restartop = 0;