From: Gerard Goossen <gerard@ggoossen.net>
Date: Wed, 4 Nov 2009 11:36:30 +0000 (+0100)
Subject: Make my_exit behave the same as the Perl exit. And add tests for it
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6bd7445c6d3b53823883c456e32ea27ce24bfc5c;p=p5sagit%2Fp5-mst-13.2.git

Make my_exit behave the same as the Perl exit. And add tests for it

Rationale: This makes the behaviour of my_exit consistent, so it no
longer depends on whether a subroutine was called using call_sv or as a
normal using an entersub op. Previously, the exit code was sometimes
converted to an exception.
---

diff --git a/MANIFEST b/MANIFEST
index d0682b4..a18091e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3211,6 +3211,7 @@ ext/XS-APItest/t/call.t		XS::APItest extension
 ext/XS-APItest/t/exception.t	XS::APItest extension
 ext/XS-APItest/t/hash.t		XS::APItest: tests for hash related APIs
 ext/XS-APItest/t/my_cxt.t	XS::APItest: test MY_CXT interface
+ext/XS-APItest/t/my_exit.t	XS::APItest: test my_exit
 ext/XS-APItest/t/op.t		XS::APItest: tests for OP related APIs
 ext/XS-APItest/t/pmflag.t	Test deprecation warning for Perl_pmflag()
 ext/XS-APItest/t/printf.t	XS::APItest extension
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index f80f3ea..11766f4 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -23,7 +23,7 @@ our @EXPORT = qw( print_double print_int print_long
 		  my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv
 		  sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore
 		  rmagical_cast rmagical_flags
-		  DPeek utf16_to_utf8 utf16_to_utf8_reversed pmflag
+		  DPeek utf16_to_utf8 utf16_to_utf8_reversed pmflag my_exit
 );
 
 our $VERSION = '0.17';
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index e8c36d7..ede6994 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -931,3 +931,8 @@ pmflag (flag, before = 0)
 	RETVAL = before;
     OUTPUT:
 	RETVAL
+
+void
+my_exit(int exitcode)
+        PPCODE:
+        my_exit(exitcode);
diff --git a/ext/XS-APItest/t/my_exit.t b/ext/XS-APItest/t/my_exit.t
new file mode 100644
index 0000000..31c0a6b
--- /dev/null
+++ b/ext/XS-APItest/t/my_exit.t
@@ -0,0 +1,33 @@
+#!perl
+
+use strict;
+use warnings;
+
+require "test.pl";
+
+plan(4);
+
+use XS::APItest;
+
+my ($prog, $expect) = (<<'PROG', <<'EXPECT');
+use XS::APItest;
+print "ok\n";
+my_exit(1);
+print "not\n";
+PROG
+ok
+EXPECT
+fresh_perl_is($prog, $expect);
+is($? >> 8, 1, "exit code plain my_exit");
+
+($prog, $expect) = (<<'PROG', <<'EXPECT');
+use XS::APItest;
+print "ok\n";
+call_sv( sub { my_exit(1); }, G_EVAL );
+print "not\n";
+PROG
+ok
+EXPECT
+fresh_perl_is($prog, $expect);
+is($? >> 8, 1, "exit code my_exit inside a call_sv with G_EVAL");
+
diff --git a/perl.c b/perl.c
index dbb2081..64ab731 100644
--- a/perl.c
+++ b/perl.c
@@ -2610,8 +2610,6 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
 	    PL_curstash = PL_defstash;
 	    FREETMPS;
 	    JMPENV_POP;
-	    if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
-		Perl_croak(aTHX_ "Callback called exit");
 	    my_exit_jump();
 	    /* NOTREACHED */
 	case 3:
@@ -2712,8 +2710,6 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
 	PL_curstash = PL_defstash;
 	FREETMPS;
 	JMPENV_POP;
-	if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
-	    Perl_croak(aTHX_ "Callback called exit");
 	my_exit_jump();
 	/* NOTREACHED */
     case 3:
@@ -4585,16 +4581,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 	    PL_curcop = &PL_compiling;
 	    CopLINE_set(PL_curcop, oldline);
 	    JMPENV_POP;
-	    if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
-		if (paramList == PL_beginav)
-		    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
-		else
-		    Perl_croak(aTHX_ "%s failed--call queue aborted",
-			       paramList == PL_checkav ? "CHECK"
-			       : paramList == PL_initav ? "INIT"
-			       : paramList == PL_unitcheckav ? "UNITCHECK"
-			       : "END");
-	    }
 	    my_exit_jump();
 	    /* NOTREACHED */
 	case 3: