EV/schmorp.h

#ifndef SCHMORP_PERL_H_
#define SCHMORP_PERL_H_

/* WARNING
 * This header file is a shared resource between many modules.
 * perl header files MUST already be included.
 */

#include <signal.h>
#include <errno.h>

#if defined(WIN32 ) || defined(_MINIX)
# define SCHMORP_H_PREFER_SELECT 1
#endif

#if !SCHMORP_H_PREFER_SELECT
# include <poll.h>
#endif

/* 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)))))

#ifndef PERL_MAGIC_ext
# define PERL_MAGIC_ext '~'
#endif

#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

/* use NV for 32 bit perls as it allows larger offsets */
#if IVSIZE >= 8
typedef IV VAL64;
# define SvVAL64(sv) SvIV (sv)
# define newSVval64(i64) newSViv (i64)
# define sv_setval64(sv,i64) sv_setiv ((sv), (i64))
#else
typedef NV VAL64;
# define SvVAL64(sv) SvNV (sv)
# define newSVval64(i64) newSVnv (i64)
# define sv_setval64(sv,i64) sv_setnv ((sv), (i64))
#endif

/* typemap for the above */
/*
VAL64           T_VAL64

INPUT

T_VAL64
        $var = ($type)SvVAL64 ($arg);

OUTPUT

T_VAL64
        $arg = newSVval64 ($var);
*/

/* 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 */

#if defined(USE_SOCKETS_AS_HANDLES) || PERL_VERSION_ATLEAST(5,18,0)
# define S_TO_HANDLE(x) ((HANDLE)win32_get_osfhandle (x))
#else
# define S_TO_HANDLE(x) ((HANDLE)x)
#endif

#ifdef _WIN32
/* taken almost verbatim from libev's ev_win32.c */
/* oh, the humanity! */
static int
s_pipe (int filedes [2])
{
  dTHX;

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

#if defined(USE_SOCKETS_AS_HANDLES) || PERL_VERSION_ATLEAST(5,18,0)
  /* 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)

static int
s_fd_blocking (int fd, int blocking)
{
  u_long nonblocking = !blocking;

  return ioctlsocket ((SOCKET)S_TO_HANDLE (fd), FIONBIO, &nonblocking);
}

#define s_fd_prepare(fd) s_fd_blocking (fd, 0)

#else

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

static int
s_fd_blocking (int fd, int blocking)
{
  return fcntl (fd, F_SETFL, blocking ? 0 : O_NONBLOCK);
}

static int
s_fd_prepare (int fd)
{
  return s_fd_blocking (fd, 0)
         || fcntl (fd, F_SETFD, FD_CLOEXEC);
}

#endif

#if HAVE_EVENTFD
# include <sys/eventfd.h>
#else
# if __linux && (__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 7))
#  define SCHMORP_H_HAVE_EVENTFD 1
/* our minimum requirement is glibc 2.7 which has the stub, but not the header */
#  include <stdint.h>
#  ifdef __cplusplus
extern "C" {
#  endif
  int eventfd (unsigned int initval, int flags);
#  ifdef __cplusplus
}
#  endif
# else
#  define eventfd(initval,flags) -1
# endif
#endif

typedef struct {
  int fd[2]; /* read, write fd, might be equal */
  int len; /* write length (1 pipe/socket, 8 eventfd) */
} s_epipe;

static int
s_epipe_new (s_epipe *epp)
{
  s_epipe ep;

  ep.fd [0] = ep.fd [1] = eventfd (0, 0);

  if (ep.fd [0] >= 0)
    {
      s_fd_prepare (ep.fd [0]);
      ep.len = 8;
    }
  else
    {
      if (s_pipe (ep.fd))
        return -1;

      if (s_fd_prepare (ep.fd [0])
          || s_fd_prepare (ep.fd [1]))
        {
           dTHX;

           close (ep.fd [0]);
           close (ep.fd [1]);
           return -1;
        }

      ep.len = 1;
    }

  *epp = ep;
  return 0;
}

static void
s_epipe_destroy (s_epipe *epp)
{
  dTHX;

  close (epp->fd [0]);

  if (epp->fd [1] != epp->fd [0])
    close (epp->fd [1]);

  epp->len = 0;
}

static void
s_epipe_signal (s_epipe *epp)
{
#ifdef _WIN32
  /* perl overrides send with a function that crashes in other threads.
   * unfortunately, it overrides it with an argument-less macro, so
   * there is no way to force usage of the real send function.
   * incompetent windows programmers - is this redundant?
   */
  DWORD dummy;
  WriteFile (S_TO_HANDLE (epp->fd [1]), (LPCVOID)&dummy, 1, &dummy, 0);
#else
  static uint64_t counter = 1;
  /* some modules accept fd's from outside, support eventfd here */
  if (write (epp->fd [1], &counter, epp->len) < 0
      && errno == EINVAL
      && epp->len != 8)
    write (epp->fd [1], &counter, (epp->len = 8));
#endif
}

static void
s_epipe_drain (s_epipe *epp)
{
  dTHX;
  char buf [9];

#ifdef _WIN32
  recv (epp->fd [0], buf, sizeof (buf), 0);
#else
  read (epp->fd [0], buf, sizeof (buf));
#endif
}

/* like new, but dups over old */
static int
s_epipe_renew (s_epipe *epp)
{
  dTHX;
  s_epipe epn;

  if (epp->fd [1] != epp->fd [0])
    close (epp->fd [1]);

  if (s_epipe_new (&epn))
    return -1;

  if (epp->len)
    {
      if (dup2 (epn.fd [0], epp->fd [0]) < 0)
        croak ("unable to dup over old event pipe"); /* should not croak */

      close (epn.fd [0]);

      if (epn.fd [0] == epn.fd [1])
        epn.fd [1] = epp->fd [0];

      epn.fd [0] = epp->fd [0];
    }

  *epp = epn;

  return 0;
}

#define s_epipe_fd(epp) ((epp)->fd [0])

static int
s_epipe_wait (s_epipe *epp)
{
  dTHX;
#if SCHMORP_H_PREFER_SELECT
  fd_set rfd;
  int fd = s_epipe_fd (epp);

  FD_ZERO (&rfd);
  FD_SET (fd, &rfd);

  return PerlSock_select (fd + 1, &rfd, 0, 0, 0);
#else
  /* poll is preferable on posix systems */
  struct pollfd pfd;

  pfd.fd = s_epipe_fd (epp);
  pfd.events = POLLIN;

  return poll (&pfd, 1, -1);
#endif
}

#endif

Revision:	1.16
Committed:	Tue Nov 19 13:08:54 2019 UTC (5 years, 11 months ago) by root
Content type:	text/plain
Branch:	MAIN
CVS Tags:	EV-rel-4_28, EV-rel-4_29, EV-rel-4_31, EV-rel-4_30, EV-rel-4_33, EV-rel-4_32, EV-rel-4_35, EV-rel-4_34, EV-rel-4_36, HEAD
Changes since 1.15:	+2 -0 lines
Log Message:	* empty log message *
#	Content
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	* perl header files MUST already be included.
7	*/
8
9	#include <signal.h>
10	#include <errno.h>
11
12	#if defined(WIN32 ) \|\| defined(_MINIX)
13	# define SCHMORP_H_PREFER_SELECT 1
14	#endif
15
16	#if !SCHMORP_H_PREFER_SELECT
17	# include <poll.h>
18	#endif
19
20	/* useful stuff, used by schmorp mostly */
21
22	#include "patchlevel.h"
23
24	#define PERL_VERSION_ATLEAST(a,b,c) \
25	(PERL_REVISION > (a) \
26	\|\| (PERL_REVISION == (a) \
27	&& (PERL_VERSION > (b) \
28	\|\| (PERL_VERSION == (b) && PERL_SUBVERSION >= (c)))))
29
30	#ifndef PERL_MAGIC_ext
31	# define PERL_MAGIC_ext '~'
32	#endif
33
34	#if !PERL_VERSION_ATLEAST (5,6,0)
35	# ifndef PL_ppaddr
36	# define PL_ppaddr ppaddr
37	# endif
38	# ifndef call_sv
39	# define call_sv perl_call_sv
40	# endif
41	# ifndef get_sv
42	# define get_sv perl_get_sv
43	# endif
44	# ifndef get_cv
45	# define get_cv perl_get_cv
46	# endif
47	# ifndef IS_PADGV
48	# define IS_PADGV(v) 0
49	# endif
50	# ifndef IS_PADCONST
51	# define IS_PADCONST(v) 0
52	# endif
53	#endif
54
55	/* use NV for 32 bit perls as it allows larger offsets */
56	#if IVSIZE >= 8
57	typedef IV VAL64;
58	# define SvVAL64(sv) SvIV (sv)
59	# define newSVval64(i64) newSViv (i64)
60	# define sv_setval64(sv,i64) sv_setiv ((sv), (i64))
61	#else
62	typedef NV VAL64;
63	# define SvVAL64(sv) SvNV (sv)
64	# define newSVval64(i64) newSVnv (i64)
65	# define sv_setval64(sv,i64) sv_setnv ((sv), (i64))
66	#endif
67
68	/* typemap for the above */
69	/*
70	VAL64 T_VAL64
71
72	INPUT
73
74	T_VAL64
75	$var = ($type)SvVAL64 ($arg);
76
77	OUTPUT
78
79	T_VAL64
80	$arg = newSVval64 ($var);
81	*/
82
83	/* 5.11 */
84	#ifndef CxHASARGS
85	# define CxHASARGS(cx) (cx)->blk_sub.hasargs
86	#endif
87
88	/* 5.10.0 */
89	#ifndef SvREFCNT_inc_NN
90	# define SvREFCNT_inc_NN(sv) SvREFCNT_inc (sv)
91	#endif
92
93	/* 5.8.8 */
94	#ifndef GV_NOTQUAL
95	# define GV_NOTQUAL 0
96	#endif
97	#ifndef newSV
98	# define newSV(l) NEWSV(0,l)
99	#endif
100	#ifndef CvISXSUB_on
101	# define CvISXSUB_on(cv) (void)cv
102	#endif
103	#ifndef CvISXSUB
104	# define CvISXSUB(cv) (CvXSUB (cv) ? TRUE : FALSE)
105	#endif
106	#ifndef Newx
107	# define Newx(ptr,nitems,type) New (0,ptr,nitems,type)
108	#endif
109
110	/* 5.8.7 */
111	#ifndef SvRV_set
112	# define SvRV_set(s,v) SvRV(s) = (v)
113	#endif
114
115	static int
116	s_signum (SV *sig)
117	{
118	#ifndef SIG_SIZE
119	/* kudos to Slaven Rezic for the idea */
120	static char sig_size [] = { SIG_NUM };
121	# define SIG_SIZE (sizeof (sig_size) + 1)
122	#endif
123	dTHX;
124	int signum;
125
126	SvGETMAGIC (sig);
127
128	for (signum = 1; signum < SIG_SIZE; ++signum)
129	if (strEQ (SvPV_nolen (sig), PL_sig_name [signum]))
130	return signum;
131
132	signum = SvIV (sig);
133
134	if (signum > 0 && signum < SIG_SIZE)
135	return signum;
136
137	return -1;
138	}
139
140	static int
141	s_signum_croak (SV *sig)
142	{
143	int signum = s_signum (sig);
144
145	if (signum < 0)
146	{
147	dTHX;
148	croak ("%s: invalid signal name or number", SvPV_nolen (sig));
149	}
150
151	return signum;
152	}
153
154	static int
155	s_fileno (SV *fh, int wr)
156	{
157	dTHX;
158	SvGETMAGIC (fh);
159
160	if (SvROK (fh))
161	{
162	fh = SvRV (fh);
163	SvGETMAGIC (fh);
164	}
165
166	if (SvTYPE (fh) == SVt_PVGV)
167	return PerlIO_fileno (wr ? IoOFP (sv_2io (fh)) : IoIFP (sv_2io (fh)));
168
169	if (SvOK (fh) && (SvIV (fh) >= 0) && (SvIV (fh) < 0x7fffffffL))
170	return SvIV (fh);
171
172	return -1;
173	}
174
175	static int
176	s_fileno_croak (SV *fh, int wr)
177	{
178	int fd = s_fileno (fh, wr);
179
180	if (fd < 0)
181	{
182	dTHX;
183	croak ("%s: illegal fh argument, either not an OS file or read/write mode mismatch", SvPV_nolen (fh));
184	}
185
186	return fd;
187	}
188
189	static SV *
190	s_get_cv (SV *cb_sv)
191	{
192	dTHX;
193	HV *st;
194	GV *gvp;
195
196	return (SV *)sv_2cv (cb_sv, &st, &gvp, 0);
197	}
198
199	static SV *
200	s_get_cv_croak (SV *cb_sv)
201	{
202	SV *cv = s_get_cv (cb_sv);
203
204	if (!cv)
205	{
206	dTHX;
207	croak ("%s: callback must be a CODE reference or another callable object", SvPV_nolen (cb_sv));
208	}
209
210	return cv;
211	}
212
213	/*****************************************************************************/
214	/* gensub: simple closure generation utility */
215
216	#define S_GENSUB_ARG CvXSUBANY (cv).any_ptr
217
218	/* create a closure from XS, returns a code reference */
219	/* the arg can be accessed via GENSUB_ARG from the callback */
220	/* the callback must use dXSARGS/XSRETURN */
221	static SV *
222	s_gensub (pTHX_ void (xsub)(pTHX_ CV ), void *arg)
223	{
224	CV cv = (CV )newSV (0);
225
226	sv_upgrade ((SV *)cv, SVt_PVCV);
227
228	CvANON_on (cv);
229	CvISXSUB_on (cv);
230	CvXSUB (cv) = xsub;
231	S_GENSUB_ARG = arg;
232
233	return newRV_noinc ((SV *)cv);
234	}
235
236	/*****************************************************************************/
237	/* portable pipe/socketpair */
238
239	#if defined(USE_SOCKETS_AS_HANDLES) \|\| PERL_VERSION_ATLEAST(5,18,0)
240	# define S_TO_HANDLE(x) ((HANDLE)win32_get_osfhandle (x))
241	#else
242	# define S_TO_HANDLE(x) ((HANDLE)x)
243	#endif
244
245	#ifdef _WIN32
246	/* taken almost verbatim from libev's ev_win32.c */
247	/* oh, the humanity! */
248	static int
249	s_pipe (int filedes [2])
250	{
251	dTHX;
252
253	struct sockaddr_in addr = { 0 };
254	int addr_size = sizeof (addr);
255	struct sockaddr_in adr2;
256	int adr2_size = sizeof (adr2);
257	SOCKET listener;
258	SOCKET sock [2] = { -1, -1 };
259
260	if ((listener = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET)
261	return -1;
262
263	addr.sin_family = AF_INET;
264	addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
265	addr.sin_port = 0;
266
267	if (bind (listener, (struct sockaddr *)&addr, addr_size))
268	goto fail;
269
270	if (getsockname (listener, (struct sockaddr *)&addr, &addr_size))
271	goto fail;
272
273	if (listen (listener, 1))
274	goto fail;
275
276	if ((sock [0] = socket (AF_INET, SOCK_STREAM, 0)) == INVALID_SOCKET)
277	goto fail;
278
279	if (connect (sock [0], (struct sockaddr *)&addr, addr_size))
280	goto fail;
281
282	if ((sock [1] = accept (listener, 0, 0)) < 0)
283	goto fail;
284
285	/* windows vista returns fantasy port numbers for getpeername.
286	* example for two interconnected tcp sockets:
287	*
288	* (Socket::unpack_sockaddr_in getsockname $sock0)[0] == 53364
289	* (Socket::unpack_sockaddr_in getpeername $sock0)[0] == 53363
290	* (Socket::unpack_sockaddr_in getsockname $sock1)[0] == 53363
291	* (Socket::unpack_sockaddr_in getpeername $sock1)[0] == 53365
292	*
293	* wow! tridirectional sockets!
294	*
295	* this way of checking ports seems to work:
296	*/
297	if (getpeername (sock [0], (struct sockaddr *)&addr, &addr_size))
298	goto fail;
299
300	if (getsockname (sock [1], (struct sockaddr *)&adr2, &adr2_size))
301	goto fail;
302
303	errno = WSAEINVAL;
304	if (addr_size != adr2_size
305	\|\| addr.sin_addr.s_addr != adr2.sin_addr.s_addr /* just to be sure, I mean, it's windows */
306	\|\| addr.sin_port != adr2.sin_port)
307	goto fail;
308
309	closesocket (listener);
310
311	#if defined(USE_SOCKETS_AS_HANDLES) \|\| PERL_VERSION_ATLEAST(5,18,0)
312	/* when select isn't winsocket, we also expect socket, connect, accept etc.
313	* to work on fds */
314	filedes [0] = sock [0];
315	filedes [1] = sock [1];
316	#else
317	filedes [0] = _open_osfhandle (sock [0], 0);
318	filedes [1] = _open_osfhandle (sock [1], 0);
319	#endif
320
321	return 0;
322
323	fail:
324	closesocket (listener);
325
326	if (sock [0] != INVALID_SOCKET) closesocket (sock [0]);
327	if (sock [1] != INVALID_SOCKET) closesocket (sock [1]);
328
329	return -1;
330	}
331
332	#define s_socketpair(domain,type,protocol,filedes) s_pipe (filedes)
333
334	static int
335	s_fd_blocking (int fd, int blocking)
336	{
337	u_long nonblocking = !blocking;
338
339	return ioctlsocket ((SOCKET)S_TO_HANDLE (fd), FIONBIO, &nonblocking);
340	}
341
342	#define s_fd_prepare(fd) s_fd_blocking (fd, 0)
343
344	#else
345
346	#define s_socketpair(domain,type,protocol,filedes) socketpair (domain, type, protocol, filedes)
347	#define s_pipe(filedes) pipe (filedes)
348
349	static int
350	s_fd_blocking (int fd, int blocking)
351	{
352	return fcntl (fd, F_SETFL, blocking ? 0 : O_NONBLOCK);
353	}
354
355	static int
356	s_fd_prepare (int fd)
357	{
358	return s_fd_blocking (fd, 0)
359	\|\| fcntl (fd, F_SETFD, FD_CLOEXEC);
360	}
361
362	#endif
363
364	#if HAVE_EVENTFD
365	# include <sys/eventfd.h>
366	#else
367	# if __linux && (__GLIBC__ > 2 \|\| (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 7))
368	# define SCHMORP_H_HAVE_EVENTFD 1
369	/* our minimum requirement is glibc 2.7 which has the stub, but not the header */
370	# include <stdint.h>
371	# ifdef __cplusplus
372	extern "C" {
373	# endif
374	int eventfd (unsigned int initval, int flags);
375	# ifdef __cplusplus
376	}
377	# endif
378	# else
379	# define eventfd(initval,flags) -1
380	# endif
381	#endif
382
383	typedef struct {
384	int fd[2]; /* read, write fd, might be equal */
385	int len; /* write length (1 pipe/socket, 8 eventfd) */
386	} s_epipe;
387
388	static int
389	s_epipe_new (s_epipe *epp)
390	{
391	s_epipe ep;
392
393	ep.fd [0] = ep.fd [1] = eventfd (0, 0);
394
395	if (ep.fd [0] >= 0)
396	{
397	s_fd_prepare (ep.fd [0]);
398	ep.len = 8;
399	}
400	else
401	{
402	if (s_pipe (ep.fd))
403	return -1;
404
405	if (s_fd_prepare (ep.fd [0])
406	\|\| s_fd_prepare (ep.fd [1]))
407	{
408	dTHX;
409
410	close (ep.fd [0]);
411	close (ep.fd [1]);
412	return -1;
413	}
414
415	ep.len = 1;
416	}
417
418	*epp = ep;
419	return 0;
420	}
421
422	static void
423	s_epipe_destroy (s_epipe *epp)
424	{
425	dTHX;
426
427	close (epp->fd [0]);
428
429	if (epp->fd [1] != epp->fd [0])
430	close (epp->fd [1]);
431
432	epp->len = 0;
433	}
434
435	static void
436	s_epipe_signal (s_epipe *epp)
437	{
438	#ifdef _WIN32
439	/* perl overrides send with a function that crashes in other threads.
440	* unfortunately, it overrides it with an argument-less macro, so
441	* there is no way to force usage of the real send function.
442	* incompetent windows programmers - is this redundant?
443	*/
444	DWORD dummy;
445	WriteFile (S_TO_HANDLE (epp->fd [1]), (LPCVOID)&dummy, 1, &dummy, 0);
446	#else
447	static uint64_t counter = 1;
448	/* some modules accept fd's from outside, support eventfd here */
449	if (write (epp->fd [1], &counter, epp->len) < 0
450	&& errno == EINVAL
451	&& epp->len != 8)
452	write (epp->fd [1], &counter, (epp->len = 8));
453	#endif
454	}
455
456	static void
457	s_epipe_drain (s_epipe *epp)
458	{
459	dTHX;
460	char buf [9];
461
462	#ifdef _WIN32
463	recv (epp->fd [0], buf, sizeof (buf), 0);
464	#else
465	read (epp->fd [0], buf, sizeof (buf));
466	#endif
467	}
468
469	/* like new, but dups over old */
470	static int
471	s_epipe_renew (s_epipe *epp)
472	{
473	dTHX;
474	s_epipe epn;
475
476	if (epp->fd [1] != epp->fd [0])
477	close (epp->fd [1]);
478
479	if (s_epipe_new (&epn))
480	return -1;
481
482	if (epp->len)
483	{
484	if (dup2 (epn.fd [0], epp->fd [0]) < 0)
485	croak ("unable to dup over old event pipe"); /* should not croak */
486
487	close (epn.fd [0]);
488
489	if (epn.fd [0] == epn.fd [1])
490	epn.fd [1] = epp->fd [0];
491
492	epn.fd [0] = epp->fd [0];
493	}
494
495	*epp = epn;
496
497	return 0;
498	}
499
500	#define s_epipe_fd(epp) ((epp)->fd [0])
501
502	static int
503	s_epipe_wait (s_epipe *epp)
504	{
505	dTHX;
506	#if SCHMORP_H_PREFER_SELECT
507	fd_set rfd;
508	int fd = s_epipe_fd (epp);
509
510	FD_ZERO (&rfd);
511	FD_SET (fd, &rfd);
512
513	return PerlSock_select (fd + 1, &rfd, 0, 0, 0);
514	#else
515	/* poll is preferable on posix systems */
516	struct pollfd pfd;
517
518	pfd.fd = s_epipe_fd (epp);
519	pfd.events = POLLIN;
520
521	return poll (&pfd, 1, -1);
522	#endif
523	}
524
525	#endif
526