Guard/Guard.xs

#define PERL_NO_GET_CONTEXT

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

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);
  SPAGAIN;

  if (SvTRUE (ERRSV))
    {
      PUSHMARK (SP);
      PUTBACK;
      call_sv (get_sv ("Guard::DIED", 1), G_VOID | G_DISCARD | G_EVAL | G_KEEPERR);
      SPAGAIN;

      sv_setpvn (ERRSV, "", 0);
    }

  if (saveerr)
    sv_setsv (ERRSV, saveerr);

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

  POPSTACK;
  PUTBACK;
}

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);
}

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

MODULE = Guard          PACKAGE = Guard

BOOT:
        guard_stash = gv_stashpv ("Guard", 1);

void
CLONE (...)
        PROTOTYPE: @
        CODE:
        guard_stash = gv_stashpv ("Guard", 1);

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);
        ++PL_sv_objcount;
        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.4
Committed:	Sat Dec 13 19:43:27 2008 UTC (15 years, 5 months ago) by root
Branch:	MAIN
Changes since 1.3:	+11 -1 lines
Log Message:	* empty log message *
#	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.3	static HV *guard_stash;
8
9	root	1.1	static SV *
10			guard_get_cv (pTHX_ SV *cb_sv)
11			{
12			HV *st;
13			GV *gvp;
14			CV *cv = sv_2cv (cb_sv, &st, &gvp, 0);
15
16			if (!cv)
17			croak ("expected a CODE reference for guard");
18
19			return (SV *)cv;
20			}
21
22			static void
23			exec_guard_cb (pTHX_ SV *cb)
24			{
25			dSP;
26			SV *saveerr = SvOK (ERRSV) ? sv_mortalcopy (ERRSV) : 0;
27	root	1.4	SV *savedie = PL_diehook;
28
29			PL_diehook = 0;
30	root	1.1
31	root	1.2	PUSHSTACKi (PERLSI_DESTROY);
32	root	1.1
33			PUSHMARK (SP);
34			PUTBACK;
35			call_sv (cb, G_VOID \| G_DISCARD \| G_EVAL);
36			SPAGAIN;
37
38			if (SvTRUE (ERRSV))
39			{
40			PUSHMARK (SP);
41			PUTBACK;
42			call_sv (get_sv ("Guard::DIED", 1), G_VOID \| G_DISCARD \| G_EVAL \| G_KEEPERR);
43			SPAGAIN;
44
45	root	1.4	sv_setpvn (ERRSV, "", 0);
46	root	1.1	}
47
48			if (saveerr)
49			sv_setsv (ERRSV, saveerr);
50
51	root	1.4	{
52			SV *oldhook = PL_diehook;
53			PL_diehook = savedie;
54			SvREFCNT_dec (oldhook);
55			}
56
57	root	1.1	POPSTACK;
58	root	1.4	PUTBACK;
59	root	1.1	}
60
61			static void
62			scope_guard_cb (pTHX_ void *cv)
63			{
64			exec_guard_cb (aTHX_ sv_2mortal ((SV *)cv));
65			}
66
67			static int
68			guard_free (pTHX_ SV cv, MAGIC mg)
69			{
70			exec_guard_cb (aTHX_ mg->mg_obj);
71			}
72
73			static MGVTBL guard_vtbl = {
74			0, 0, 0, 0,
75			guard_free
76			};
77
78			MODULE = Guard PACKAGE = Guard
79
80	root	1.3	BOOT:
81			guard_stash = gv_stashpv ("Guard", 1);
82
83			void
84			CLONE (...)
85			PROTOTYPE: @
86			CODE:
87			guard_stash = gv_stashpv ("Guard", 1);
88
89	root	1.1	void
90			scope_guard (SV *block)
91			PROTOTYPE: &
92			CODE:
93			LEAVE; /* unfortunately, perl sandwiches XS calls into ENTER/LEAVE */
94			SAVEDESTRUCTOR_X (scope_guard_cb, (void *)SvREFCNT_inc (guard_get_cv (aTHX_ block)));
95			ENTER; /* unfortunately, perl sandwiches XS calls into ENTER/LEAVE */
96
97			SV *
98			guard (SV *block)
99			PROTOTYPE: &
100			CODE:
101			{
102			SV *cv = guard_get_cv (aTHX_ block);
103			SV *guard = NEWSV (0, 0);
104			SvUPGRADE (guard, SVt_PVMG);
105			sv_magicext (guard, cv, PERL_MAGIC_ext, &guard_vtbl, 0, 0);
106			RETVAL = newRV_noinc (guard);
107	root	1.3	SvOBJECT_on (guard);
108			++PL_sv_objcount;
109			SvSTASH_set (guard, (HV)SvREFCNT_inc ((SV )guard_stash));
110	root	1.1	}
111			OUTPUT:
112			RETVAL
113
114			void
115			cancel (SV *guard)
116			PROTOTYPE: $
117			CODE:
118			{
119			MAGIC *mg;
120			if (!SvROK (guard)
121			\|\| !(mg = mg_find (SvRV (guard), PERL_MAGIC_ext))
122			\|\| mg->mg_virtual != &guard_vtbl)
123			croak ("Guard::cancel called on a non-guard object");
124
125			SvREFCNT_dec (mg->mg_obj);
126			mg->mg_obj = 0;
127			mg->mg_virtual = 0;
128			}