From: Gurusamy Sarathy Date: Fri, 28 Mar 1997 00:31:42 +0000 (-0500) Subject: Re: embedded perl and top_env problem X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f289f7d2518e7a8a82114282e774adf50fa6ce85;p=p5sagit%2Fp5-mst-13.2.git Re: embedded perl and top_env problem On Mon, 24 Mar 1997 17:29:29 EST, Ken Fox wrote: >Gurusamy Sarathy wrote: >> >> Ken Fox wrote: >> >> > The trouble with die happens in the longjmp to top_env ... >> Testcase? > >Here's a good example that demonstrates both of my longjmp related >problems. I'm using 5.003_94 on Solaris 2.5.1 (more info at >bottom). I think that the perl_call_* API is being used correctly. > >---------------------------------------- BEGIN crash.c >#include >#include >static PerlInterpreter *my_perl; > >int call_sub(SV *sub) >{ > int result = -1; > int count; > dSP; > > ENTER; > SAVETMPS; > > PUSHMARK(sp); > XPUSHs(sv_2mortal(newSViv(1))); > PUTBACK; > count = perl_call_sv(sub, G_SCALAR); > SPAGAIN; > if (count == 1) result = POPi; > PUTBACK; > > FREETMPS; > LEAVE; > return result; >} > >int main(int argc, char *argv[], char *envp[]) >{ > char *perl_args[] = { 0, "-e", > "sub ok { $_[0] + 1; } sub crash { die 'crash\n'; }", 0 }; > my_perl = perl_alloc(); > perl_construct(my_perl); > perl_parse(my_perl, 0, 3, perl_args, 0); > perl_run(my_perl); > > /* this call works fine -- no error */ > printf(" sub ok: return = %d\n", call_sub((SV *)perl_get_cv("ok", FALSE))); > /* this call eventually inokes die() which mangles the C stack with long jump */ > printf("sub crash: return = %d\n", call_sub((SV *)perl_get_cv("crash", FALSE))); > /* this call is bogus but perl mangles the C stack with long jump trying to > tell me about it. */ > printf(" sv_undef: return = %d\n", call_sub(&sv_undef)); > perl_destruct(my_perl); > perl_free(my_perl); > return 0; >} >---------------------------------------- END crash.c > >I don't expect either of these cases to trap the error and go on -- I'd >have used G_EVAL to do that. What I do expect is that the C stack isn't >scrambled when the error occurs -- that makes it virtually impossible to >catch in a debugger: Here's a patch for the above problem, which is symptomatic of larger problems with perl_call_*() calls that happen outside perl_run() or perl_parse(). Perl invokes longjmp() without checking if an associated setjmp() exists. This is likely to cause coredumps galore for all the perl embedfellows out there. Note the size of this patch is mostly due to the conversion of the DOCATCH() business to macros in order to give it a semblance of order. It also does away with redundant calls to setjmp() (the :restart branch in perl_call_sv()), and uses the C stack instead of Copy(). I finished this patch yesterday, and gave it a day with my production embeded app, so I'm fairly sure it don't have no bugs. :-) p5p-msgid: 199703280031.TAA05711@aatma.engin.umich.edu --- diff --git a/gv.c b/gv.c index cc520d6..8611e35 100644 --- a/gv.c +++ b/gv.c @@ -1282,14 +1282,14 @@ int flags; dSP; BINOP myop; SV* res; - bool oldmustcatch = mustcatch; + bool oldcatch = CATCH_GET; + CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; myop.op_next = Nullop; myop.op_flags = OPf_KNOW|OPf_STACKED; - mustcatch = TRUE; ENTER; SAVESPTR(op); op = (OP *) &myop; @@ -1315,7 +1315,7 @@ int flags; res=POPs; PUTBACK; - mustcatch = oldmustcatch; + CATCH_SET(oldcatch); if (postpr) { int ans; diff --git a/interp.sym b/interp.sym index a82c2c4..80ef5b5 100644 --- a/interp.sym +++ b/interp.sym @@ -85,7 +85,6 @@ minus_l minus_n minus_p multiline -mustcatch mystack_base mystack_mark mystack_max @@ -126,6 +125,7 @@ sortcop sortstack sortstash splitstr +start_env statcache statgv statname diff --git a/perl.c b/perl.c index 5846c82..0bd1ad1 100644 --- a/perl.c +++ b/perl.c @@ -140,6 +140,10 @@ register PerlInterpreter *sv_interp; init_ids(); + start_env.je_prev = NULL; + start_env.je_ret = -1; + start_env.je_mustcatch = TRUE; + top_env = &start_env; STATUS_ALL_SUCCESS; SET_NUMERIC_STANDARD(); @@ -451,6 +455,7 @@ char **env; char *validarg = ""; I32 oldscope; AV* comppadlist; + dJMPENV; #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -498,9 +503,8 @@ setuid perl scripts securely.\n"); time(&basetime); oldscope = scopestack_ix; - mustcatch = FALSE; - switch (Sigsetjmp(top_env,1)) { + switch (JMPENV_PUSH) { case 1: STATUS_ALL_FAILURE; /* FALL THROUGH */ @@ -511,9 +515,10 @@ setuid perl scripts securely.\n"); curstash = defstash; if (endav) call_list(oldscope, endav); + JMPENV_POP; return STATUS_NATIVE_EXPORT; case 3: - mustcatch = FALSE; + JMPENV_POP; PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; } @@ -784,6 +789,7 @@ setuid perl scripts securely.\n"); ENTER; restartop = 0; + JMPENV_POP; return 0; } @@ -791,6 +797,7 @@ int perl_run(sv_interp) PerlInterpreter *sv_interp; { + dJMPENV; I32 oldscope; if (!(curinterp = sv_interp)) @@ -798,7 +805,7 @@ PerlInterpreter *sv_interp; oldscope = scopestack_ix; - switch (Sigsetjmp(top_env,1)) { + switch (JMPENV_PUSH) { case 1: cxstack_ix = -1; /* start context stack again */ break; @@ -814,12 +821,13 @@ PerlInterpreter *sv_interp; if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif + JMPENV_POP; return STATUS_NATIVE_EXPORT; case 3: - mustcatch = FALSE; if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); FREETMPS; + JMPENV_POP; return 1; } if (curstack != mainstack) { @@ -858,6 +866,7 @@ PerlInterpreter *sv_interp; } my_exit(0); + /* NOTREACHED */ return 0; } @@ -968,10 +977,10 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark; I32 retval; - Sigjmp_buf oldtop; I32 oldscope; static CV *DBcv; - bool oldmustcatch = mustcatch; + bool oldcatch = CATCH_GET; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1002,8 +1011,6 @@ I32 flags; /* See G_* flags in cop.h */ op->op_private |= OPpENTERSUB_DB; if (flags & G_EVAL) { - Copy(top_env, oldtop, 1, Sigjmp_buf); - cLOGOP->op_other = op; markstack_ptr--; /* we're trying to emulate pp_entertry() here */ @@ -1027,8 +1034,7 @@ I32 flags; /* See G_* flags in cop.h */ } markstack_ptr++; - restart: - switch (Sigsetjmp(top_env,1)) { + switch (JMPENV_PUSH) { case 0: break; case 1: @@ -1038,17 +1044,16 @@ I32 flags; /* See G_* flags in cop.h */ /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (statusvalue) croak("Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: - mustcatch = FALSE; if (restartop) { op = restartop; restartop = 0; - goto restart; + break; } stack_sp = stack_base + oldmark; if (flags & G_ARRAY) @@ -1061,7 +1066,7 @@ I32 flags; /* See G_* flags in cop.h */ } } else - mustcatch = TRUE; + CATCH_SET(TRUE); if (op == (OP*)&myop) op = pp_entersub(); @@ -1086,10 +1091,10 @@ I32 flags; /* See G_* flags in cop.h */ curpm = newpm; LEAVE; } - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; } else - mustcatch = oldmustcatch; + CATCH_SET(oldcatch); if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; @@ -1111,8 +1116,8 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark = sp - stack_base; I32 retval; - Sigjmp_buf oldtop; I32 oldscope; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1136,10 +1141,7 @@ I32 flags; /* See G_* flags in cop.h */ if (flags & G_ARRAY) myop.op_flags |= OPf_LIST; - Copy(top_env, oldtop, 1, Sigjmp_buf); - -restart: - switch (Sigsetjmp(top_env,1)) { + switch (JMPENV_PUSH) { case 0: break; case 1: @@ -1149,17 +1151,16 @@ restart: /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (statusvalue) croak("Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: - mustcatch = FALSE; if (restartop) { op = restartop; restartop = 0; - goto restart; + break; } stack_sp = stack_base + oldmark; if (flags & G_ARRAY) @@ -1180,7 +1181,7 @@ restart: sv_setpv(GvSV(errgv),""); cleanup: - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; retval = 0; @@ -2442,25 +2443,23 @@ call_list(oldscope, list) I32 oldscope; AV* list; { - Sigjmp_buf oldtop; + dJMPENV; STRLEN len; line_t oldline = curcop->cop_line; - Copy(top_env, oldtop, 1, Sigjmp_buf); - while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); - switch (Sigsetjmp(top_env,1)) { + switch (JMPENV_PUSH) { case 0: { SV* atsv = GvSV(errgv); PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); (void)SvPV(atsv, len); if (len) { - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; if (list == beginav) @@ -2484,7 +2483,7 @@ AV* list; if (endav) call_list(oldscope, endav); FREETMPS; - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; if (statusvalue) { @@ -2501,14 +2500,13 @@ AV* list; FREETMPS; break; } - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; - Siglongjmp(top_env, 3); + JMPENV_JUMP(3); } + JMPENV_POP; } - - Copy(oldtop, top_env, 1, Sigjmp_buf); } void @@ -2576,5 +2574,5 @@ my_exit_jump() LEAVE; } - Siglongjmp(top_env, 2); + JMPENV_JUMP(2); } diff --git a/perl.h b/perl.h index 42740ba..71f97ba 100644 --- a/perl.h +++ b/perl.h @@ -1843,9 +1843,9 @@ IEXT line_t Icopline IINIT(NOLINE); IEXT CONTEXT * Icxstack; IEXT I32 Icxstack_ix IINIT(-1); IEXT I32 Icxstack_max IINIT(128); -IEXT Sigjmp_buf Itop_env; +IEXT JMPENV Istart_env; /* empty startup sigjmp() environment */ +IEXT JMPENV * Itop_env; /* ptr. to current sigjmp() environment */ IEXT I32 Irunlevel; -IEXT bool Imustcatch; /* doeval() must be caught locally */ /* stack stuff */ IEXT AV * Icurstack; /* THE STACK */ diff --git a/pp_ctl.c b/pp_ctl.c index c423f00..a690a51 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -23,7 +23,7 @@ #define WORD_ALIGN sizeof(U16) #endif -#define DOCATCH(o) (mustcatch ? docatch(o) : (o)) +#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) static OP *docatch _((OP *o)); static OP *doeval _((int gimme)); @@ -628,7 +628,7 @@ PP(pp_sort) AV *oldstack; CONTEXT *cx; SV** newsp; - bool oldmustcatch = mustcatch; + bool oldcatch = CATCH_GET; SAVETMPS; SAVESPTR(op); @@ -639,7 +639,7 @@ PP(pp_sort) AvREAL_off(sortstack); av_extend(sortstack, 32); } - mustcatch = TRUE; + CATCH_SET(TRUE); SWITCHSTACK(curstack, sortstack); if (sortstash != stash) { firstgv = gv_fetchpv("a", TRUE, SVt_PV); @@ -656,7 +656,7 @@ PP(pp_sort) POPBLOCK(cx,curpm); SWITCHSTACK(sortstack, oldstack); - mustcatch = oldmustcatch; + CATCH_SET(oldcatch); } LEAVE; } @@ -1843,7 +1843,7 @@ PP(pp_goto) if (curstack == signalstack) { restartop = retop; - Siglongjmp(top_env, 3); + JMPENV_JUMP(3); } RETURNOP(retop); @@ -1943,28 +1943,25 @@ OP *o; int ret; int oldrunlevel = runlevel; OP *oldop = op; - Sigjmp_buf oldtop; + dJMPENV; op = o; - Copy(top_env, oldtop, 1, Sigjmp_buf); #ifdef DEBUGGING - assert(mustcatch == TRUE); + assert(CATCH_GET == TRUE); + DEBUG_l(deb("(Setting up local jumplevel, runlevel = %d)\n", runlevel+1)); #endif - mustcatch = FALSE; - switch ((ret = Sigsetjmp(top_env,1))) { + switch ((ret = JMPENV_PUSH)) { default: /* topmost level handles it */ - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; runlevel = oldrunlevel; - mustcatch = TRUE; op = oldop; - Siglongjmp(top_env, ret); + JMPENV_JUMP(ret); /* NOTREACHED */ case 3: if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); break; } - mustcatch = FALSE; op = restartop; restartop = 0; /* FALL THROUGH */ @@ -1972,9 +1969,8 @@ OP *o; runops(); break; } - Copy(oldtop, top_env, 1, Sigjmp_buf); + JMPENV_POP; runlevel = oldrunlevel; - mustcatch = TRUE; op = oldop; return Nullop; } diff --git a/pp_sys.c b/pp_sys.c index 998d271..6f8b449 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -463,7 +463,7 @@ PP(pp_tie) SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */ I32 markoff = mark - stack_base - 1; char *methname; - bool oldmustcatch = mustcatch; + bool oldcatch = CATCH_GET; varsv = mark[0]; if (SvTYPE(varsv) == SVt_PVHV) @@ -484,7 +484,7 @@ PP(pp_tie) myop.op_last = (OP *) &myop; myop.op_next = Nullop; myop.op_flags = OPf_KNOW|OPf_STACKED; - mustcatch = TRUE; + CATCH_SET(TRUE); ENTER; SAVESPTR(op); @@ -499,7 +499,7 @@ PP(pp_tie) runops(); SPAGAIN; - mustcatch = oldmustcatch; + CATCH_SET(oldcatch); sv = TOPs; if (sv_isobject(sv)) { if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) { @@ -576,7 +576,7 @@ PP(pp_dbmopen) GV *gv; BINOP myop; SV *sv; - bool oldmustcatch = mustcatch; + bool oldcatch = CATCH_GET; hv = (HV*)POPs; @@ -595,7 +595,7 @@ PP(pp_dbmopen) myop.op_last = (OP *) &myop; myop.op_next = Nullop; myop.op_flags = OPf_KNOW|OPf_STACKED; - mustcatch = TRUE; + CATCH_SET(TRUE); ENTER; SAVESPTR(op); @@ -638,7 +638,7 @@ PP(pp_dbmopen) SPAGAIN; } - mustcatch = oldmustcatch; + CATCH_SET(oldcatch); if (sv_isobject(TOPs)) sv_magic((SV*)hv, TOPs, 'P', Nullch, 0); LEAVE; diff --git a/scope.h b/scope.h index d0931b1..d6eb270 100644 --- a/scope.h +++ b/scope.h @@ -70,3 +70,43 @@ SSPUSHINT(SAVEt_STACK_POS); \ } STMT_END + +/* A jmpenv packages the state required to perform a proper non-local jump. + * Note that there is a start_env initialized when perl starts, and top_env + * 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_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 + */ + +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 */ +}; + +typedef struct jmpenv JMPENV; + +#define dJMPENV JMPENV cur_env +#define JMPENV_PUSH (cur_env.je_prev = top_env, \ + cur_env.je_ret = Sigsetjmp(cur_env.je_buf,1), \ + top_env = &cur_env, \ + cur_env.je_mustcatch = FALSE, \ + cur_env.je_ret) +#define JMPENV_POP (top_env = cur_env.je_prev) +#define JMPENV_JUMP(v) (top_env->je_prev ? Siglongjmp(top_env->je_buf, (v)) \ + : ((v) == 2) ? exit(STATUS_NATIVE_EXPORT) \ + : (PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"), \ + exit(1))) + +#define CATCH_GET (top_env->je_mustcatch) +#define CATCH_SET(v) (top_env->je_mustcatch = (v)) + diff --git a/util.c b/util.c index 1317a76..0316269 100644 --- a/util.c +++ b/util.c @@ -1209,7 +1209,7 @@ die(pat, va_alist) restartop = die_where(message); if ((!restartop && was_in_eval) || oldrunlevel > 1) - Siglongjmp(top_env, 3); + JMPENV_JUMP(3); return restartop; } @@ -1264,7 +1264,7 @@ croak(pat, va_alist) } if (in_eval) { restartop = die_where(message); - Siglongjmp(top_env, 3); + JMPENV_JUMP(3); } PerlIO_puts(PerlIO_stderr(),message); (void)PerlIO_flush(PerlIO_stderr());