Async-Interrupt/schmorp.h

#ifndef SCHMORP_PERL_H_
#define SCHMORP_PERL_H_

/* WARNING
 * This header file is a shared resource between many modules.
 */

/* useful stuff, used by schmorp mostly */

#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)))))

#if !PERL_VERSION_ATLEAST (5,6,0)
# ifndef PL_ppaddr
#  define PL_ppaddr ppaddr
# endif
# ifndef call_sv
#  define call_sv perl_call_sv
# endif
# ifndef get_sv
#  define get_sv perl_get_sv
# endif
# ifndef get_cv
#  define get_cv perl_get_cv
# endif
# ifndef IS_PADGV
#  define IS_PADGV(v) 0
# endif
# ifndef IS_PADCONST
#  define IS_PADCONST(v) 0
# endif
#endif

/* 5.11 */
#ifndef CxHASARGS
# define CxHASARGS(cx) (cx)->blk_sub.hasargs
#endif

/* 5.10.0 */
#ifndef SvREFCNT_inc_NN
# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
#endif

/* 5.8.8 */
#ifndef GV_NOTQUAL
# define GV_NOTQUAL 0
#endif
#ifndef newSV
# define newSV(l) NEWSV(0,l)
#endif
#ifndef CvISXSUB_on
# define CvISXSUB_on(cv) (void)cv
#endif
#ifndef CvISXSUB
# define CvISXSUB(cv) (CvXSUB (cv) ? TRUE : FALSE)
#endif
#ifndef Newx
# define Newx(ptr,nitems,type) New (0,ptr,nitems,type)
#endif

/* 5.8.7 */
#ifndef SvRV_set
# define SvRV_set(s,v) SvRV(s) = (v)
#endif

static int
s_signum (SV *sig)
{
#ifndef SIG_SIZE
  /* kudos to Slaven Rezic for the idea */
  static char sig_size [] = { SIG_NUM };
# define SIG_SIZE (sizeof (sig_size) + 1)
#endif
  dTHX;
  int signum;

  SvGETMAGIC (sig);

  for (signum = 1; signum < SIG_SIZE; ++signum)
    if (strEQ (SvPV_nolen (sig), PL_sig_name [signum]))
      return signum;

  signum = SvIV (sig);

  if (signum > 0 && signum < SIG_SIZE)
    return signum;

  return -1;
}

static int
s_signum_croak (SV *sig)
{
  int signum = s_signum (sig);

  if (signum < 0)
    {
      dTHX;
      croak ("%s: invalid signal name or number", SvPV_nolen (sig));
    }

  return signum;
}

static int
s_fileno (SV *fh, int wr)
{
  dTHX;
  SvGETMAGIC (fh);

  if (SvROK (fh))
    {
      fh = SvRV (fh);
      SvGETMAGIC (fh);
    }

  if (SvTYPE (fh) == SVt_PVGV)
    return PerlIO_fileno (wr ? IoOFP (sv_2io (fh)) : IoIFP (sv_2io (fh)));

  if (SvOK (fh) && (SvIV (fh) >= 0) && (SvIV (fh) < 0x7fffffffL))
    return SvIV (fh);

  return -1;
}

static int
s_fileno_croak (SV *fh, int wr)
{
  int fd = s_fileno (fh, wr);

  if (fd < 0)
    {
      dTHX;
      croak ("%s: illegal fh argument, either not an OS file or read/write mode mismatch", SvPV_nolen (fh));
    }

  return fd;
}

static SV *
s_get_cv (SV *cb_sv)
{
  dTHX;
  HV *st;
  GV *gvp;

  return (SV *)sv_2cv (cb_sv, &st, &gvp, 0);
}

static SV *
s_get_cv_croak (SV *cb_sv)
{
  SV *cv = s_get_cv (cb_sv);

  if (!cv)
    {
      dTHX;
      croak ("%s: callback must be a CODE reference or another callable object", SvPV_nolen (cb_sv));
    }

  return cv;
}

/*****************************************************************************/
/* gensub: simple closure generation utility */

#define S_GENSUB_ARG CvXSUBANY (cv).any_ptr

/* create a closure from XS, returns a code reference */
/* the arg can be accessed via GENSUB_ARG from the callback */
/* the callback must use dXSARGS/XSRETURN */
static SV *
s_gensub (pTHX_ void (*xsub)(pTHX_ CV *), void *arg)
{
  CV *cv = (CV *)newSV (0);

  sv_upgrade ((SV *)cv, SVt_PVCV);

  CvANON_on (cv);
  CvISXSUB_on (cv);
  CvXSUB (cv) = xsub;
  S_GENSUB_ARG = arg;

  return newRV_noinc ((SV *)cv);
}

/** portable pipe/socketpair */

#ifdef USE_SOCKETS_AS_HANDLES
# define S_TO_SOCKET(x) (win32_get_osfhandle (x))
#else
# define S_TO_SOCKET(x) (x)
#endif

#ifdef _WIN32
/* taken almost verbatim from libev's ev_win32.c */
/* oh, the humanity! */
static int
s_pipe (int filedes [2])
{
  struct sockaddr_in addr = { 0 };
  int addr_size = sizeof (addr);
  struct sockaddr_in adr2;
  int adr2_size = sizeof (adr2);
  SOCKET listener;
  SOCKET sock [2] = { -1, -1 };

  if ((listener = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET) 
    return -1;

  addr.sin_family = AF_INET;
  addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
  addr.sin_port = 0;

  if (bind (listener, (struct sockaddr *)&addr, addr_size))
    goto fail;

  if (getsockname (listener, (struct sockaddr *)&addr, &addr_size))
    goto fail;

  if (listen (listener, 1))
    goto fail;

  if ((sock [0] = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET) 
    goto fail;

  if (connect (sock [0], (struct sockaddr *)&addr, addr_size))
    goto fail;

  if ((sock [1] = accept (listener, 0, 0)) < 0)
    goto fail;

  /* windows vista returns fantasy port numbers for getpeername.
   * example for two interconnected tcp sockets:
   *
   * (Socket::unpack_sockaddr_in getsockname $sock0)[0] == 53364
   * (Socket::unpack_sockaddr_in getpeername $sock0)[0] == 53363
   * (Socket::unpack_sockaddr_in getsockname $sock1)[0] == 53363
   * (Socket::unpack_sockaddr_in getpeername $sock1)[0] == 53365
   *
   * wow! tridirectional sockets!
   *
   * this way of checking ports seems to work:
   */
  if (getpeername (sock [0], (struct sockaddr *)&addr, &addr_size))
    goto fail;

  if (getsockname (sock [1], (struct sockaddr *)&adr2, &adr2_size))
    goto fail;

  errno = WSAEINVAL;
  if (addr_size != adr2_size
      || addr.sin_addr.s_addr != adr2.sin_addr.s_addr /* just to be sure, I mean, it's windows */
      || addr.sin_port        != adr2.sin_port)
    goto fail;

  closesocket (listener);

#ifdef USE_SOCKETS_AS_HANDLES
  /* when select isn't winsocket, we also expect socket, connect, accept etc.
   * to work on fds */
  filedes [0] = sock [0];
  filedes [1] = sock [1];
#else
  filedes [0] = _open_osfhandle (sock [0], 0);
  filedes [1] = _open_osfhandle (sock [1], 0);
#endif

  return 0;

fail:
  closesocket (listener);

  if (sock [0] != INVALID_SOCKET) closesocket (sock [0]);
  if (sock [1] != INVALID_SOCKET) closesocket (sock [1]);

  return -1;
}

#define s_socketpair(domain,type,protocol,filedes) s_pipe (filedes)

#else

#define s_socketpair(domain,type,protocol,filedes) socketpair (domain, type, protocol, filedes)
#define s_pipe(filedes) pipe (filedes)

#endif

#endif

Revision:	1.1
Committed:	Tue Jul 14 19:29:26 2009 UTC (17 years, 2 months ago) by root
Content type:	text/plain
Branch:	MAIN
CVS Tags:	rel-0_042
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	#ifndef SCHMORP_PERL_H_
2			#define SCHMORP_PERL_H_
3
4			/* WARNING
5			* This header file is a shared resource between many modules.
6			*/
7
8			/* useful stuff, used by schmorp mostly */
9
10			#include "patchlevel.h"
11
12			#define PERL_VERSION_ATLEAST(a,b,c) \
13			(PERL_REVISION > (a) \
14			\|\| (PERL_REVISION == (a) \
15			&& (PERL_VERSION > (b) \
16			\|\| (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))
17
18			#if !PERL_VERSION_ATLEAST (5,6,0)
19			# ifndef PL_ppaddr
20			# define PL_ppaddr ppaddr
21			# endif
22			# ifndef call_sv
23			# define call_sv perl_call_sv
24			# endif
25			# ifndef get_sv
26			# define get_sv perl_get_sv
27			# endif
28			# ifndef get_cv
29			# define get_cv perl_get_cv
30			# endif
31			# ifndef IS_PADGV
32			# define IS_PADGV(v) 0
33			# endif
34			# ifndef IS_PADCONST
35			# define IS_PADCONST(v) 0
36			# endif
37			#endif
38
39			/* 5.11 */
40			#ifndef CxHASARGS
41			# define CxHASARGS(cx) (cx)->blk_sub.hasargs
42			#endif
43
44			/* 5.10.0 */
45			#ifndef SvREFCNT_inc_NN
46			# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
47			#endif
48
49			/* 5.8.8 */
50			#ifndef GV_NOTQUAL
51			# define GV_NOTQUAL 0
52			#endif
53			#ifndef newSV
54			# define newSV(l) NEWSV(0,l)
55			#endif
56			#ifndef CvISXSUB_on
57			# define CvISXSUB_on(cv) (void)cv
58			#endif
59			#ifndef CvISXSUB
60			# define CvISXSUB(cv) (CvXSUB (cv) ? TRUE : FALSE)
61			#endif
62			#ifndef Newx
63			# define Newx(ptr,nitems,type) New (0,ptr,nitems,type)
64			#endif
65
66			/* 5.8.7 */
67			#ifndef SvRV_set
68			# define SvRV_set(s,v) SvRV(s) = (v)
69			#endif
70
71			static int
72			s_signum (SV *sig)
73			{
74			#ifndef SIG_SIZE
75			/* kudos to Slaven Rezic for the idea */
76			static char sig_size [] = { SIG_NUM };
77			# define SIG_SIZE (sizeof (sig_size) + 1)
78			#endif
79			dTHX;
80			int signum;
81
82			SvGETMAGIC (sig);
83
84			for (signum = 1; signum < SIG_SIZE; ++signum)
85			if (strEQ (SvPV_nolen (sig), PL_sig_name [signum]))
86			return signum;
87
88			signum = SvIV (sig);
89
90			if (signum > 0 && signum < SIG_SIZE)
91			return signum;
92
93			return -1;
94			}
95
96			static int
97			s_signum_croak (SV *sig)
98			{
99			int signum = s_signum (sig);
100
101			if (signum < 0)
102			{
103			dTHX;
104			croak ("%s: invalid signal name or number", SvPV_nolen (sig));
105			}
106
107			return signum;
108			}
109
110			static int
111			s_fileno (SV *fh, int wr)
112			{
113			dTHX;
114			SvGETMAGIC (fh);
115
116			if (SvROK (fh))
117			{
118			fh = SvRV (fh);
119			SvGETMAGIC (fh);
120			}
121
122			if (SvTYPE (fh) == SVt_PVGV)
123			return PerlIO_fileno (wr ? IoOFP (sv_2io (fh)) : IoIFP (sv_2io (fh)));
124
125			if (SvOK (fh) && (SvIV (fh) >= 0) && (SvIV (fh) < 0x7fffffffL))
126			return SvIV (fh);
127
128			return -1;
129			}
130
131			static int
132			s_fileno_croak (SV *fh, int wr)
133			{
134			int fd = s_fileno (fh, wr);
135
136			if (fd < 0)
137			{
138			dTHX;
139			croak ("%s: illegal fh argument, either not an OS file or read/write mode mismatch", SvPV_nolen (fh));
140			}
141
142			return fd;
143			}
144
145			static SV *
146			s_get_cv (SV *cb_sv)
147			{
148			dTHX;
149			HV *st;
150			GV *gvp;
151
152			return (SV *)sv_2cv (cb_sv, &st, &gvp, 0);
153			}
154
155			static SV *
156			s_get_cv_croak (SV *cb_sv)
157			{
158			SV *cv = s_get_cv (cb_sv);
159
160			if (!cv)
161			{
162			dTHX;
163			croak ("%s: callback must be a CODE reference or another callable object", SvPV_nolen (cb_sv));
164			}
165
166			return cv;
167			}
168
169			/*****************************************************************************/
170			/* gensub: simple closure generation utility */
171
172			#define S_GENSUB_ARG CvXSUBANY (cv).any_ptr
173
174			/* create a closure from XS, returns a code reference */
175			/* the arg can be accessed via GENSUB_ARG from the callback */
176			/* the callback must use dXSARGS/XSRETURN */
177			static SV *
178			s_gensub (pTHX_ void (xsub)(pTHX_ CV ), void *arg)
179			{
180			CV cv = (CV )newSV (0);
181
182			sv_upgrade ((SV *)cv, SVt_PVCV);
183
184			CvANON_on (cv);
185			CvISXSUB_on (cv);
186			CvXSUB (cv) = xsub;
187			S_GENSUB_ARG = arg;
188
189			return newRV_noinc ((SV *)cv);
190			}
191
192			/** portable pipe/socketpair */
193
194			#ifdef USE_SOCKETS_AS_HANDLES
195			# define S_TO_SOCKET(x) (win32_get_osfhandle (x))
196			#else
197			# define S_TO_SOCKET(x) (x)
198			#endif
199
200			#ifdef _WIN32
201			/* taken almost verbatim from libev's ev_win32.c */
202			/* oh, the humanity! */
203			static int
204			s_pipe (int filedes [2])
205			{
206			struct sockaddr_in addr = { 0 };
207			int addr_size = sizeof (addr);
208			struct sockaddr_in adr2;
209			int adr2_size = sizeof (adr2);
210			SOCKET listener;
211			SOCKET sock [2] = { -1, -1 };
212
213			if ((listener = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET)
214			return -1;
215
216			addr.sin_family = AF_INET;
217			addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
218			addr.sin_port = 0;
219
220			if (bind (listener, (struct sockaddr *)&addr, addr_size))
221			goto fail;
222
223			if (getsockname (listener, (struct sockaddr *)&addr, &addr_size))
224			goto fail;
225
226			if (listen (listener, 1))
227			goto fail;
228
229			if ((sock [0] = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET)
230			goto fail;
231
232			if (connect (sock [0], (struct sockaddr *)&addr, addr_size))
233			goto fail;
234
235			if ((sock [1] = accept (listener, 0, 0)) < 0)
236			goto fail;
237
238			/* windows vista returns fantasy port numbers for getpeername.
239			* example for two interconnected tcp sockets:
240			*
241			* (Socket::unpack_sockaddr_in getsockname $sock0)[0] == 53364
242			* (Socket::unpack_sockaddr_in getpeername $sock0)[0] == 53363
243			* (Socket::unpack_sockaddr_in getsockname $sock1)[0] == 53363
244			* (Socket::unpack_sockaddr_in getpeername $sock1)[0] == 53365
245			*
246			* wow! tridirectional sockets!
247			*
248			* this way of checking ports seems to work:
249			*/
250			if (getpeername (sock [0], (struct sockaddr *)&addr, &addr_size))
251			goto fail;
252
253			if (getsockname (sock [1], (struct sockaddr *)&adr2, &adr2_size))
254			goto fail;
255
256			errno = WSAEINVAL;
257			if (addr_size != adr2_size
258			\|\| addr.sin_addr.s_addr != adr2.sin_addr.s_addr /* just to be sure, I mean, it's windows */
259			\|\| addr.sin_port != adr2.sin_port)
260			goto fail;
261
262			closesocket (listener);
263
264			#ifdef USE_SOCKETS_AS_HANDLES
265			/* when select isn't winsocket, we also expect socket, connect, accept etc.
266			* to work on fds */
267			filedes [0] = sock [0];
268			filedes [1] = sock [1];
269			#else
270			filedes [0] = _open_osfhandle (sock [0], 0);
271			filedes [1] = _open_osfhandle (sock [1], 0);
272			#endif
273
274			return 0;
275
276			fail:
277			closesocket (listener);
278
279			if (sock [0] != INVALID_SOCKET) closesocket (sock [0]);
280			if (sock [1] != INVALID_SOCKET) closesocket (sock [1]);
281
282			return -1;
283			}
284
285			#define s_socketpair(domain,type,protocol,filedes) s_pipe (filedes)
286
287			#else
288
289			#define s_socketpair(domain,type,protocol,filedes) socketpair (domain, type, protocol, filedes)
290			#define s_pipe(filedes) pipe (filedes)
291
292			#endif
293
294			#endif
295