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 <EXTERN.h>
>#include <perl.h>
>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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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());