Add simple exception handling macros for XS writers.

p4raw-id: //depot/perl@23911

6 files changed, 118 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index dc1193e104..7d33530f29 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -915,6 +915,7 @@ ext/XS/APItest/Makefile.PL	XS::APItest extension
 ext/XS/APItest/MANIFEST		XS::APItest extension
 ext/XS/APItest/README		XS::APItest extension
 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 extension
 ext/XS/APItest/t/printf.t	XS::APItest extension
 ext/XS/APItest/t/push.t		XS::APItest extension
diff --git a/XSUB.h b/XSUB.h
index 8d8de8d033..6751572c8a 100644
--- a/XSUB.h
+++ b/XSUB.h
@@ -192,6 +192,24 @@ Macro to verify that a PM module's $VERSION variable matches the XS
 module's C<XS_VERSION> variable.  This is usually handled automatically by
 C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
 
+=head1 Simple Exception Handling Macros
+
+=for apidoc Ams||dXCPT
+Set up neccessary local variables for exception handling.
+See L<perlguts/"Exception Handling">.
+
+=for apidoc AmU||XCPT_TRY_START
+Starts a try block.  See L<perlguts/"Exception Handling">.
+
+=for apidoc AmU||XCPT_TRY_END
+Ends a try block.  See L<perlguts/"Exception Handling">.
+
+=for apidoc AmU||XCPT_CATCH
+Introduces a catch block.  See L<perlguts/"Exception Handling">.
+
+=for apidoc Ams||XCPT_RETHROW
+Rethrows a previously caught exception.  See L<perlguts/"Exception Handling">.
+
 =cut
 */
 
@@ -254,6 +272,12 @@ C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
 #  define XS_VERSION_BOOTCHECK
 #endif
 
+#define dXCPT             dJMPENV; int rEtV = 0
+#define XCPT_TRY_START    JMPENV_PUSH(rEtV); if (rEtV == 0)
+#define XCPT_TRY_END      JMPENV_POP;
+#define XCPT_CATCH        if (rEtV != 0)
+#define XCPT_RETHROW      JMPENV_JUMP(rEtV)
+
 /* 
    The DBM_setFilter & DBM_ckFilter macros are only used by 
    the *DB*_File modules 
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);
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 4d045318d3..7f23169011 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -2260,6 +2260,34 @@ and
         AV *av = ...;
         UV  uv = PTR2UV(av);
 
+=head2 Exception Handling
+
+There are a couple of macros to do very basic exception handling in
+XS modules. You can use these macros if you call code that may croak,
+but you need to do some cleanup before giving control back to Perl.
+For example:
+
+        dXCPT;    /* set up neccessary variables */
+
+        XCPT_TRY_START {
+          code_that_may_croak();
+        } XCPT_TRY_END
+
+        XCPT_CATCH
+        {
+          /* do cleanup here */
+          XCPT_RETHROW;
+        }
+
+Note that you always have to rethrow an exception that has been
+caught. Using these macros, it is not possible to just catch the
+exception and ignore it. If you have to ignore the exception, you
+have to use the C<call_*> function.
+
+The advantage of using the above macros is that you don't have
+to setup an extra function for C<call_*>, and that using these
+macros is faster than using C<call_*>.
+
 =head2 Source Documentation
 
 There's an effort going on to document the internal functions and