1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
#define ST(off) PL_stack_base[ax + (off)]
#ifdef CAN_PROTOTYPE
#ifdef PERL_OBJECT
#define XS(name) void name(CV* cv, CPerlObj* pPerl)
#else
#define XS(name) void name(CV* cv)
#endif
#else
#define XS(name) void name(cv) CV* cv;
#endif
#define dXSARGS \
dSP; dMARK; \
I32 ax = mark - PL_stack_base + 1; \
I32 items = sp - mark
#define XSANY CvXSUBANY(cv)
#define dXSI32 I32 ix = XSANY.any_i32
#ifdef __cplusplus
# define XSINTERFACE_CVT(ret,name) ret (*name)(...)
#else
# define XSINTERFACE_CVT(ret,name) ret (*name)()
#endif
#define dXSFUNCTION(ret) XSINTERFACE_CVT(ret,XSFUNCTION)
#define XSINTERFACE_FUNC(ret,cv,f) ((XSINTERFACE_CVT(ret,))(f))
#define XSINTERFACE_FUNC_SET(cv,f) \
CvXSUBANY(cv).any_dptr = (void (*) _((void*)))(f)
#define XSRETURN(off) \
STMT_START { \
PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
return; \
} STMT_END
/* Simple macros to put new mortal values onto the stack. */
/* Typically used to return values from XS functions. */
#define XST_mIV(i,v) (ST(i) = sv_2mortal(newSViv(v)) )
#define XST_mNV(i,v) (ST(i) = sv_2mortal(newSVnv(v)) )
#define XST_mPV(i,v) (ST(i) = sv_2mortal(newSVpv(v,0)))
#define XST_mNO(i) (ST(i) = &PL_sv_no )
#define XST_mYES(i) (ST(i) = &PL_sv_yes )
#define XST_mUNDEF(i) (ST(i) = &PL_sv_undef)
#define XSRETURN_IV(v) STMT_START { XST_mIV(0,v); XSRETURN(1); } STMT_END
#define XSRETURN_NV(v) STMT_START { XST_mNV(0,v); XSRETURN(1); } STMT_END
#define XSRETURN_PV(v) STMT_START { XST_mPV(0,v); XSRETURN(1); } STMT_END
#define XSRETURN_NO STMT_START { XST_mNO(0); XSRETURN(1); } STMT_END
#define XSRETURN_YES STMT_START { XST_mYES(0); XSRETURN(1); } STMT_END
#define XSRETURN_UNDEF STMT_START { XST_mUNDEF(0); XSRETURN(1); } STMT_END
#define XSRETURN_EMPTY STMT_START { XSRETURN(0); } STMT_END
#define newXSproto(a,b,c,d) sv_setpv((SV*)newXS(a,b,c), d)
#ifdef XS_VERSION
# define XS_VERSION_BOOTCHECK \
STMT_START { \
SV *tmpsv; STRLEN n_a; \
char *vn = Nullch, *module = SvPV(ST(0),n_a); \
if (items >= 2) /* version supplied as bootstrap arg */ \
tmpsv = ST(1); \
else { \
/* XXX GV_ADDWARN */ \
tmpsv = perl_get_sv(form("%s::%s", module, \
vn = "XS_VERSION"), FALSE); \
if (!tmpsv || !SvOK(tmpsv)) \
tmpsv = perl_get_sv(form("%s::%s", module, \
vn = "VERSION"), FALSE); \
} \
if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, n_a)))) \
croak("%s object version %s does not match %s%s%s%s %_", \
module, XS_VERSION, \
vn ? "$" : "", vn ? module : "", vn ? "::" : "", \
vn ? vn : "bootstrap parameter", tmpsv); \
} STMT_END
#else
# define XS_VERSION_BOOTCHECK
#endif
#ifdef PERL_CAPI
# define VTBL_sv get_vtbl(want_vtbl_sv)
# define VTBL_env get_vtbl(want_vtbl_env)
# define VTBL_envelem get_vtbl(want_vtbl_envelem)
# define VTBL_sig get_vtbl(want_vtbl_sig)
# define VTBL_sigelem get_vtbl(want_vtbl_sigelem)
# define VTBL_pack get_vtbl(want_vtbl_pack)
# define VTBL_packelem get_vtbl(want_vtbl_packelem)
# define VTBL_dbline get_vtbl(want_vtbl_dbline)
# define VTBL_isa get_vtbl(want_vtbl_isa)
# define VTBL_isaelem get_vtbl(want_vtbl_isaelem)
# define VTBL_arylen get_vtbl(want_vtbl_arylen)
# define VTBL_glob get_vtbl(want_vtbl_glob)
# define VTBL_mglob get_vtbl(want_vtbl_mglob)
# define VTBL_nkeys get_vtbl(want_vtbl_nkeys)
# define VTBL_taint get_vtbl(want_vtbl_taint)
# define VTBL_substr get_vtbl(want_vtbl_substr)
# define VTBL_vec get_vtbl(want_vtbl_vec)
# define VTBL_pos get_vtbl(want_vtbl_pos)
# define VTBL_bm get_vtbl(want_vtbl_bm)
# define VTBL_fm get_vtbl(want_vtbl_fm)
# define VTBL_uvar get_vtbl(want_vtbl_uvar)
# define VTBL_defelem get_vtbl(want_vtbl_defelem)
# define VTBL_regexp get_vtbl(want_vtbl_regexp)
# ifdef USE_LOCALE_COLLATE
# define VTBL_collxfrm get_vtbl(want_vtbl_collxfrm)
# endif
# ifdef OVERLOAD
# define VTBL_amagic get_vtbl(want_vtbl_amagic)
# define VTBL_amagicelem get_vtbl(want_vtbl_amagicelem)
# endif
#else
# define VTBL_sv &vtbl_sv
# define VTBL_env &vtbl_env
# define VTBL_envelem &vtbl_envelem
# define VTBL_sig &vtbl_sig
# define VTBL_sigelem &vtbl_sigelem
# define VTBL_pack &vtbl_pack
# define VTBL_packelem &vtbl_packelem
# define VTBL_dbline &vtbl_dbline
# define VTBL_isa &vtbl_isa
# define VTBL_isaelem &vtbl_isaelem
# define VTBL_arylen &vtbl_arylen
# define VTBL_glob &vtbl_glob
# define VTBL_mglob &vtbl_mglob
# define VTBL_nkeys &vtbl_nkeys
# define VTBL_taint &vtbl_taint
# define VTBL_substr &vtbl_substr
# define VTBL_vec &vtbl_vec
# define VTBL_pos &vtbl_pos
# define VTBL_bm &vtbl_bm
# define VTBL_fm &vtbl_fm
# define VTBL_uvar &vtbl_uvar
# define VTBL_defelem &vtbl_defelem
# define VTBL_regexp &vtbl_regexp
# ifdef USE_LOCALE_COLLATE
# define VTBL_collxfrm &vtbl_collxfrm
# endif
# ifdef OVERLOAD
# define VTBL_amagic &vtbl_amagic
# define VTBL_amagicelem &vtbl_amagicelem
# endif
#endif
#ifdef PERL_OBJECT
#include "objXSUB.h"
#ifndef NO_XSLOCKS
#ifdef WIN32
#include "XSlock.h"
#endif /* WIN32 */
#endif /* NO_XSLOCKS */
#else
#ifdef PERL_CAPI
#include "perlCAPI.h"
#endif
#endif /* PERL_OBJECT */
|
