Add simple exception handling macros for XS writers.

p4raw-id: //depot/perl@23911

3 files changed, 65 insertions, 2 deletions

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 1fdae73668..7d42a66aa6 100644
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -19,6 +19,7 @@ our @EXPORT = qw( print_double print_int print_long
 		  call_sv call_pv call_method eval_sv eval_pv require_pv
 		  G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS
 		  G_KEEPERR G_NODEBUG G_METHOD
+		  exception
 );
 
 # from cop.h 
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index c675b839d5..9b7da1226d 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -2,6 +2,32 @@
 #include "perl.h"
 #include "XSUB.h"
 
+static void throws_exception(int throw_e)
+{
+  if (throw_e)
+    croak("boo\n");
+}
+
+static int exception(int throw_e)
+{
+  dTHR;
+  dXCPT;
+  SV *caught = get_sv("XS::APItest::exception_caught", 0);
+
+  XCPT_TRY_START {
+    throws_exception(throw_e);
+  } XCPT_TRY_END
+
+  XCPT_CATCH
+  {
+    sv_setiv(caught, 1);
+    XCPT_RETHROW;
+  }
+
+  sv_setiv(caught, 0);
+
+  return 42;
+}
 
 MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
 
@@ -329,6 +355,9 @@ require_pv(pv)
 	PUTBACK;
 	require_pv(pv);
 
-
-
+int
+exception(throw_e)
+    int throw_e
+    OUTPUT:
+        RETVAL
 
diff --git a/ext/XS/APItest/t/exception.t b/ext/XS/APItest/t/exception.t
new file mode 100644
index 0000000000..c910f25d83
--- /dev/null
+++ b/ext/XS/APItest/t/exception.t
@@ -0,0 +1,33 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 8;
+
+BEGIN { use_ok('XS::APItest') };
+
+#########################
+
+my $rv;
+
+$XS::APItest::exception_caught = undef;
+
+$rv = eval { exception(0) };
+is($@, '');
+ok(defined $rv);
+is($rv, 42);
+is($XS::APItest::exception_caught, 0);
+
+$XS::APItest::exception_caught = undef;
+
+$rv = eval { exception(1) };
+is($@, "boo\n");
+ok(not defined $rv);
+is($XS::APItest::exception_caught, 1);