This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
299695820c0b2f288e6dfd570eeacb9da386855c
[perl5.git] / ext / Devel / PPPort / parts / inc / exception
1 ################################################################################
2 ##
3 ##  $Revision: 2 $
4 ##  $Author: mhx $
5 ##  $Date: 2005/01/31 08:10:51 +0100 $
6 ##
7 ################################################################################
8 ##
9 ##  Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
10 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
11 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
12 ##
13 ##  This program is free software; you can redistribute it and/or
14 ##  modify it under the same terms as Perl itself.
15 ##
16 ################################################################################
17
18 =provides
19
20 dXCPT
21 XCPT_TRY_START
22 XCPT_TRY_END
23 XCPT_CATCH
24 XCPT_RETHROW
25
26 =implementation
27
28 #ifdef dJMPENV
29
30 #  ifndef dXCPT
31 #    define dXCPT             dJMPENV; int rEtV = 0
32 #    define XCPT_TRY_START    JMPENV_PUSH(rEtV); if (rEtV == 0)
33 #    define XCPT_TRY_END      JMPENV_POP;
34 #    define XCPT_CATCH        if (rEtV != 0)
35 #    define XCPT_RETHROW      JMPENV_JUMP(rEtV)
36 #  endif
37
38 #else
39
40 #  define dXCPT             Sigjmp_buf oldTOP; int rEtV = 0
41 #  define XCPT_TRY_START    Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
42 #  define XCPT_TRY_END      Copy(oldTOP, top_env, 1, Sigjmp_buf);
43 #  define XCPT_CATCH        if (rEtV != 0)
44 #  define XCPT_RETHROW      Siglongjmp(top_env, rEtV)
45
46 #endif
47
48 =xsmisc
49
50 static void throws_exception(int throw_e)
51 {
52   if (throw_e)
53     croak("boo\n");
54 }
55
56 static int exception(int throw_e)
57 {
58   dTHR;
59   dXCPT;
60   SV *caught = get_sv("Devel::PPPort::exception_caught", 0);
61
62   XCPT_TRY_START {
63     throws_exception(throw_e);
64   } XCPT_TRY_END
65
66   XCPT_CATCH
67   {
68     sv_setiv(caught, 1);
69     XCPT_RETHROW;
70   }
71
72   sv_setiv(caught, 0);
73
74   return 42;
75 }
76
77 =xsubs
78
79 int
80 exception(throw_e)
81   int throw_e
82   OUTPUT:
83     RETVAL
84
85 =tests plan => 7
86
87 my $rv;
88
89 $Devel::PPPort::exception_caught = undef;
90
91 $rv = eval { &Devel::PPPort::exception(0) };
92 ok($@, '');
93 ok(defined $rv);
94 ok($rv, 42);
95 ok($Devel::PPPort::exception_caught, 0);
96
97 $Devel::PPPort::exception_caught = undef;
98
99 $rv = eval { &Devel::PPPort::exception(1) };
100 ok($@, "boo\n");
101 ok(not defined $rv);
102 ok($Devel::PPPort::exception_caught, 1);