Guard/Guard.xs

#define PERL_NO_GET_CONTEXT

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "patchlevel.h"

#define PERL_VERSION_ATLEAST(a,b,c)                             \
  (PERL_REVISION > (a)                                          \
   || (PERL_REVISION == (a)                                     \
       && (PERL_VERSION > (b)                                   \
           || (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))

/* apparently < 5.8.8 */
#ifndef SvSTASH_set
# define SvSTASH_set(x,a) SvSTASH(x) = (a)
#endif

#ifndef PERL_MAGIC_ext
# define PERL_MAGIC_ext '~'
#endif

static HV *guard_stash;

static SV *
guard_get_cv (pTHX_ SV *cb_sv)
{
  HV *st;
  GV *gvp;
  CV *cv = sv_2cv (cb_sv, &st, &gvp, 0);

  if (!cv)
    croak ("expected a CODE reference for guard");

  return (SV *)cv;
}

static void
exec_guard_cb (pTHX_ SV *cb)
{
  dSP;
  SV *saveerr = SvOK (ERRSV) ? sv_mortalcopy (ERRSV) : 0;
  SV *savedie = PL_diehook;

  PL_diehook = 0;

  PUSHSTACKi (PERLSI_DESTROY);

  PUSHMARK (SP);
  PUTBACK;
  call_sv (cb, G_VOID | G_DISCARD | G_EVAL);

  if (SvTRUE (ERRSV))
    {
      SPAGAIN;

      PUSHMARK (SP);
      PUTBACK;
      call_sv (get_sv ("Guard::DIED", 1), G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);

      sv_setpvn (ERRSV, "", 0);
    }

  if (saveerr)
    sv_setsv (ERRSV, saveerr);

  {
    SV *oldhook = PL_diehook;
    PL_diehook = savedie;
    SvREFCNT_dec (oldhook);
  }

  POPSTACK;
}

static void
scope_guard_cb (pTHX_ void *cv)
{
  exec_guard_cb (aTHX_ sv_2mortal ((SV *)cv));
}

static int
guard_free (pTHX_ SV *cv, MAGIC *mg)
{
  exec_guard_cb (aTHX_ mg->mg_obj);

  return 0;
}

static MGVTBL guard_vtbl = {
  0, 0, 0, 0,
  guard_free
};

MODULE = Guard          PACKAGE = Guard

BOOT:
        guard_stash = gv_stashpv ("Guard", 1);
        CvNODEBUG_on (get_cv ("Guard::scope_guard", 0)); /* otherwise calling scope can be the debugger */

void
scope_guard (SV *block)
        PROTOTYPE: &
        CODE:
        LEAVE; /* unfortunately, perl sandwiches XS calls into ENTER/LEAVE */
        SAVEDESTRUCTOR_X (scope_guard_cb, (void *)SvREFCNT_inc (guard_get_cv (aTHX_ block)));
        ENTER; /* unfortunately, perl sandwiches XS calls into ENTER/LEAVE */

SV *
guard (SV *block)
        PROTOTYPE: &
        CODE:
{
        SV *cv = guard_get_cv (aTHX_ block);
        SV *guard = NEWSV (0, 0);
        SvUPGRADE (guard, SVt_PVMG);
        sv_magicext (guard, cv, PERL_MAGIC_ext, &guard_vtbl, 0, 0);
        RETVAL = newRV_noinc (guard);
        SvOBJECT_on (guard);
#if !PERL_VERSION_ATLEAST(5,18,0)
        ++PL_sv_objcount;
#endif
        SvSTASH_set (guard, (HV*)SvREFCNT_inc ((SV *)guard_stash));
}
        OUTPUT:
        RETVAL

void
cancel (SV *guard)
        PROTOTYPE: $
        CODE:
{
        MAGIC *mg;
        if (!SvROK (guard)
            || !(mg = mg_find (SvRV (guard), PERL_MAGIC_ext))
            || mg->mg_virtual != &guard_vtbl)
          croak ("Guard::cancel called on a non-guard object");

        SvREFCNT_dec (mg->mg_obj);
        mg->mg_obj     = 0;
        mg->mg_virtual = 0;
}
Revision:	1.12
Committed:	Thu Nov 20 18:13:58 2014 UTC (9 years, 5 months ago) by root
Branch:	MAIN
CVS Tags:	rel-1_023, HEAD
Changes since 1.11:	+11 -1 lines
Log Message:	1.023
#	User	Rev	Content
1	root	1.1	#define PERL_NO_GET_CONTEXT
2
3			#include "EXTERN.h"
4			#include "perl.h"
5			#include "XSUB.h"
6
7	root	1.12	#include "patchlevel.h"
8
9			#define PERL_VERSION_ATLEAST(a,b,c) \
10			(PERL_REVISION > (a) \
11			\|\| (PERL_REVISION == (a) \
12			&& (PERL_VERSION > (b) \
13			\|\| (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))
14
15	root	1.11	/* apparently < 5.8.8 */
16	root	1.10	#ifndef SvSTASH_set
17			# define SvSTASH_set(x,a) SvSTASH(x) = (a)
18			#endif
19
20			#ifndef PERL_MAGIC_ext
21			# define PERL_MAGIC_ext '~'
22			#endif
23
24	root	1.3	static HV *guard_stash;
25
26	root	1.1	static SV *
27			guard_get_cv (pTHX_ SV *cb_sv)
28			{
29			HV *st;
30			GV *gvp;
31			CV *cv = sv_2cv (cb_sv, &st, &gvp, 0);
32
33			if (!cv)
34			croak ("expected a CODE reference for guard");
35
36			return (SV *)cv;
37			}
38
39			static void
40			exec_guard_cb (pTHX_ SV *cb)
41			{
42			dSP;
43			SV *saveerr = SvOK (ERRSV) ? sv_mortalcopy (ERRSV) : 0;
44	root	1.4	SV *savedie = PL_diehook;
45
46			PL_diehook = 0;
47	root	1.1
48	root	1.2	PUSHSTACKi (PERLSI_DESTROY);
49	root	1.1
50			PUSHMARK (SP);
51			PUTBACK;
52			call_sv (cb, G_VOID \| G_DISCARD \| G_EVAL);
53
54			if (SvTRUE (ERRSV))
55			{
56	root	1.7	SPAGAIN;
57
58	root	1.1	PUSHMARK (SP);
59			PUTBACK;
60			call_sv (get_sv ("Guard::DIED", 1), G_VOID \| G_DISCARD \| G_EVAL \| G_KEEPERR);
61
62	root	1.4	sv_setpvn (ERRSV, "", 0);
63	root	1.1	}
64
65			if (saveerr)
66			sv_setsv (ERRSV, saveerr);
67
68	root	1.4	{
69			SV *oldhook = PL_diehook;
70			PL_diehook = savedie;
71			SvREFCNT_dec (oldhook);
72			}
73
74	root	1.1	POPSTACK;
75			}
76
77			static void
78			scope_guard_cb (pTHX_ void *cv)
79			{
80			exec_guard_cb (aTHX_ sv_2mortal ((SV *)cv));
81			}
82
83			static int
84			guard_free (pTHX_ SV cv, MAGIC mg)
85			{
86			exec_guard_cb (aTHX_ mg->mg_obj);
87	root	1.8
88			return 0;
89	root	1.1	}
90
91			static MGVTBL guard_vtbl = {
92			0, 0, 0, 0,
93			guard_free
94			};
95
96			MODULE = Guard PACKAGE = Guard
97
98	root	1.3	BOOT:
99			guard_stash = gv_stashpv ("Guard", 1);
100	root	1.9	CvNODEBUG_on (get_cv ("Guard::scope_guard", 0)); /* otherwise calling scope can be the debugger */
101	root	1.3
102			void
103	root	1.1	scope_guard (SV *block)
104			PROTOTYPE: &
105			CODE:
106			LEAVE; /* unfortunately, perl sandwiches XS calls into ENTER/LEAVE */
107			SAVEDESTRUCTOR_X (scope_guard_cb, (void *)SvREFCNT_inc (guard_get_cv (aTHX_ block)));
108			ENTER; /* unfortunately, perl sandwiches XS calls into ENTER/LEAVE */
109
110			SV *
111			guard (SV *block)
112			PROTOTYPE: &
113			CODE:
114			{
115	root	1.12	SV *cv = guard_get_cv (aTHX_ block);
116	root	1.1	SV *guard = NEWSV (0, 0);
117			SvUPGRADE (guard, SVt_PVMG);
118			sv_magicext (guard, cv, PERL_MAGIC_ext, &guard_vtbl, 0, 0);
119			RETVAL = newRV_noinc (guard);
120	root	1.3	SvOBJECT_on (guard);
121	root	1.12	#if !PERL_VERSION_ATLEAST(5,18,0)
122	root	1.3	++PL_sv_objcount;
123	root	1.12	#endif
124	root	1.3	SvSTASH_set (guard, (HV)SvREFCNT_inc ((SV )guard_stash));
125	root	1.1	}
126			OUTPUT:
127			RETVAL
128
129			void
130			cancel (SV *guard)
131			PROTOTYPE: $
132			CODE:
133			{
134			MAGIC *mg;
135			if (!SvROK (guard)
136			\|\| !(mg = mg_find (SvRV (guard), PERL_MAGIC_ext))
137			\|\| mg->mg_virtual != &guard_vtbl)
138			croak ("Guard::cancel called on a non-guard object");
139
140			SvREFCNT_dec (mg->mg_obj);
141			mg->mg_obj = 0;
142			mg->mg_virtual = 0;
143			}