avoid "Callback called exit" error on intentional exit()

p4raw-id: //depot/perl@4609

diff --git a/embedvar.h b/embedvar.h
index 2ceb49e..5519520 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -241,6 +241,7 @@
 #define PL_eval_root           (PERL_GET_INTERP->Ieval_root)
 #define PL_eval_start          (PERL_GET_INTERP->Ieval_start)
 #define PL_evalseq             (PERL_GET_INTERP->Ievalseq)
+#define PL_exit_flags          (PERL_GET_INTERP->Iexit_flags)
 #define PL_exitlist            (PERL_GET_INTERP->Iexitlist)
 #define PL_exitlistlen         (PERL_GET_INTERP->Iexitlistlen)
 #define PL_expect              (PERL_GET_INTERP->Iexpect)
@@ -506,6 +507,7 @@
 #define PL_eval_root           (vTHX->Ieval_root)
 #define PL_eval_start          (vTHX->Ieval_start)
 #define PL_evalseq             (vTHX->Ievalseq)
+#define PL_exit_flags          (vTHX->Iexit_flags)
 #define PL_exitlist            (vTHX->Iexitlist)
 #define PL_exitlistlen         (vTHX->Iexitlistlen)
 #define PL_expect              (vTHX->Iexpect)
@@ -908,6 +910,7 @@
 #define PL_eval_root           (aTHXo->interp.Ieval_root)
 #define PL_eval_start          (aTHXo->interp.Ieval_start)
 #define PL_evalseq             (aTHXo->interp.Ievalseq)
+#define PL_exit_flags          (aTHXo->interp.Iexit_flags)
 #define PL_exitlist            (aTHXo->interp.Iexitlist)
 #define PL_exitlistlen         (aTHXo->interp.Iexitlistlen)
 #define PL_expect              (aTHXo->interp.Iexpect)
@@ -1174,6 +1177,7 @@
 #define PL_Ieval_root          PL_eval_root
 #define PL_Ieval_start         PL_eval_start
 #define PL_Ievalseq            PL_evalseq
+#define PL_Iexit_flags         PL_exit_flags
 #define PL_Iexitlist           PL_exitlist
 #define PL_Iexitlistlen                PL_exitlistlen
 #define PL_Iexpect             PL_expect

diff --git a/intrpvar.h b/intrpvar.h
index d7a669c..9731bc3 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -56,6 +56,7 @@ PERLVARI(Imaxsysfd,   I32,    MAXSYSFD)
                                        /* top fd to pass to subprocesses */
 PERLVAR(Imultiline,    int)            /* $*--do strings hold >1 line? */
 PERLVAR(Istatusvalue,  I32)            /* $? */
+PERLVAR(Iexit_flags,   U8)             /* was exit() unexpected, etc. */
 #ifdef VMS
 PERLVAR(Istatusvalue_vms,U32)
 #endif

diff --git a/objXSUB.h b/objXSUB.h
index 0884936..72555ef 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -148,6 +148,8 @@
 #define PL_eval_start          (*Perl_Ieval_start_ptr(aTHXo))
 #undef  PL_evalseq
 #define PL_evalseq             (*Perl_Ievalseq_ptr(aTHXo))
+#undef  PL_exit_flags
+#define PL_exit_flags          (*Perl_Iexit_flags_ptr(aTHXo))
 #undef  PL_exitlist
 #define PL_exitlist            (*Perl_Iexitlist_ptr(aTHXo))
 #undef  PL_exitlistlen

diff --git a/perl.c b/perl.c
index 0fb2f35..800e83b 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1406,7 +1406,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
            /* my_exit() was called */
            PL_curstash = PL_defstash;
            FREETMPS;
-           if (PL_statusvalue)
+           if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
                Perl_croak(aTHX_ "Callback called exit");
            my_exit_jump();
            /* NOTREACHED */
@@ -1530,7 +1530,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
        /* my_exit() was called */
        PL_curstash = PL_defstash;
        FREETMPS;
-       if (PL_statusvalue)
+       if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
            Perl_croak(aTHX_ "Callback called exit");
        my_exit_jump();
        /* NOTREACHED */
@@ -3169,7 +3169,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
            PL_curstash = PL_defstash;
            PL_curcop = &PL_compiling;
            CopLINE_set(PL_curcop, oldline);
-           if (PL_statusvalue) {
+           if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
                if (paramList == PL_beginav)
                    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
                else

diff --git a/perl.h b/perl.h
index f0dcf1e..7197dcc 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1592,6 +1592,9 @@ typedef pthread_key_t     perl_key;
 #   define STATUS_ALL_FAILURE  (PL_statusvalue = 1)
 #endif
 
+/* flags in PL_exit_flags for nature of exit() */
+#define PERL_EXIT_EXPECTED     0x01
+
 #ifndef MEMBER_TO_FPTR
 #define MEMBER_TO_FPTR(name)           name
 #endif

diff --git a/pp_ctl.c b/pp_ctl.c
index b1f71a3..ec7dfb8 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2394,6 +2394,7 @@ PP(pp_exit)
            anum = 0;
 #endif
     }
+    PL_exit_flags |= PERL_EXIT_EXPECTED;
     my_exit(anum);
     PUSHs(&PL_sv_undef);
     RETURN;