From: Joshua Pritikin Date: Sun, 14 Jun 1998 14:03:15 +0000 (-0400) Subject: added patch, fixed typo, reworked documentation X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1163b5c41f1e1e2856ca82fef1598bfbb6c54d72;p=p5sagit%2Fp5-mst-13.2.git added patch, fixed typo, reworked documentation Message-Id: Subject: [PATCH 5.004_66] JMPENV! p4raw-id: //depot/perl@1135 --- diff --git a/ObjXSub.h b/ObjXSub.h index 605ef1c..5bdac21 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 fe830c0..7d28ff5 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 c5b537e..bca4108 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 2e64829..2441767 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 9b3308f..a455804 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 7bbb11e..344af2c 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 74c914b..9f5f41b 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 757a65b..ba192d2 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 7b76edf..a119a45 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,451 +679,68 @@ setuid perl scripts securely.\n"); main_cv = Nullcv; time(&basetime); - oldscope = scopestack_ix; + locals.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; - } + TRYBLOCK(PerlParseVtbl, locals); + return locals.ret; +} - sv_setpvn(linestr,"",0); - sv = newSVpv("",0); /* first used for -I flags */ - SAVEFREESV(sv); - init_main_stash(); +struct try_run_locals { + I32 oldscope; + int ret; +}; +typedef struct try_run_locals TRY_RUN_LOCALS; +static TRYVTBL PerlRunVtbl; - 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]; +int +#ifdef PERL_OBJECT +CPerlObj::perl_run(void) +#else +perl_run(PerlInterpreter *sv_interp) #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; +{ + dTHR; + TRY_RUN_LOCALS locals; - case 'T': - tainting = TRUE; - s++; - goto reswitch; +#ifndef PERL_OBJECT + if (!(curinterp = sv_interp)) + return 255; +#endif - 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; + locals.oldscope = scopestack_ix; + TRYBLOCK(PerlRunVtbl, locals); + return locals.ret; +} - 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); +SV* +perl_get_sv(char *name, I32 create) +{ + GV *gv; +#ifdef USE_THREADS + if (name[1] == '\0' && !isALPHA(name[0])) { + PADOFFSET tmp = find_threadsv(name); + if (tmp != NOT_IN_PAD) { + dTHR; + return THREADSV(tmp); } } - switch_end: +#endif /* USE_THREADS */ + gv = gv_fetchpv(name, create, SVt_PV); + if (gv) + return GvSV(gv); + return Nullsv; +} - 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; - JMPENV_POP; - return 0; -} - -int -#ifdef PERL_OBJECT -CPerlObj::perl_run(void) -#else -perl_run(PerlInterpreter *sv_interp) -#endif -{ - dSP; - I32 oldscope; - dJMPENV; - int ret; - -#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; -} - -SV* -perl_get_sv(char *name, I32 create) -{ - GV *gv; -#ifdef USE_THREADS - if (name[1] == '\0' && !isALPHA(name[0])) { - PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) { - dTHR; - return THREADSV(tmp); - } - } -#endif /* USE_THREADS */ - gv = gv_fetchpv(name, create, SVt_PV); - if (gv) - return GvSV(gv); - return Nullsv; -} - -AV* -perl_get_av(char *name, I32 create) -{ - GV* gv = gv_fetchpv(name, create, SVt_PVAV); - if (create) - return GvAVn(gv); - if (gv) - return GvAV(gv); - return Nullav; -} +AV* +perl_get_av(char *name, I32 create) +{ + GV* gv = gv_fetchpv(name, create, SVt_PVAV); + if (create) + return GvAVn(gv); + if (gv) + return GvAV(gv); + return Nullav; +} HV* perl_get_hv(char *name, I32 create) @@ -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 60f7dd5..b8a5cb7 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 8dd2f82..e35ad46 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. + =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. =item panic: yylex diff --git a/pod/perlguts.pod b/pod/perlguts.pod index fb52ecf..dce6ca5 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. +=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 macro is used to set up a exception handling switch. +C 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. + +The second argument to C 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 except for +C, which is the only thing executed by C +after setting up the exception context. Any code executed by +C is free to throw one of the three supported exceptions +using C. C 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 is called, either +C, C, or C are executed. +If C is invoked yet again before the try handler completes +then execution will B at the try handler which corresponds to the +most recent C. 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. Of course, they may +be caught at some outer exception trap set up for the purpose. Therefore, +C at this point will not be trapped; it will jump to the +previous C. This is useful for propagating exceptions to the +top of the stack. + +WARNING: At the time of this writing, the C 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 9b924bc..ac2ddfc 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 2356e68..4467dde 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 5958aba..c0924d8 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 cc349f0..7170365 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 = ⊤ \ +} 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 2fa7740..f1cd3bc 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;