From: Gurusamy Sarathy <gsar@cpan.org>
Date: Wed, 1 Dec 1999 18:43:49 +0000 (+0000)
Subject: avoid "Callback called exit" error on intentional exit()
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cc3604b14c0748189384ba69182e0ae2c73a4d88;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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;