1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 #include <stddef.h>
7
8 #ifdef I_SYS_TYPES
9 # include <sys/types.h>
10 #endif
11 #if !defined(ultrix) /* Avoid double definition. */
12 # include <sys/socket.h>
13 #endif
14 #if defined(USE_SOCKS) && defined(I_SOCKS)
15 # include <socks.h>
16 #endif
17 #ifdef MPE
18 # define PF_INET AF_INET
19 # define PF_UNIX AF_UNIX
20 # define SOCK_RAW 3
21 #endif
22 #ifdef I_SYS_UN
23 # include <sys/un.h>
24 #endif
25 /* XXX Configure test for <netinet/in_systm.h needed XXX */
26 #if defined(NeXT) || defined(__NeXT__)
27 # include <netinet/in_systm.h>
28 #endif
29 #if defined(__sgi) && !defined(AF_LINK) && defined(PF_LINK) && PF_LINK == AF_LNK
30 # undef PF_LINK
31 #endif
32 #if defined(I_NETINET_IN) || defined(__ultrix__)
33 # include <netinet/in.h>
34 #endif
35 #if defined(I_NETINET_IP)
36 # include <netinet/ip.h>
37 #endif
38 #ifdef I_NETDB
39 # if !defined(ultrix) /* Avoid double definition. */
40 # include <netdb.h>
41 # endif
42 #endif
43 #ifdef I_ARPA_INET
44 # include <arpa/inet.h>
45 #endif
46 #ifdef I_NETINET_TCP
47 # include <netinet/tcp.h>
48 #endif
49
50 #if defined(WIN32) && !defined(UNDER_CE)
51 # include <ws2tcpip.h>
52 #endif
53
54 #ifdef WIN32
55
56 /* VC 6 with its original headers doesn't know about sockaddr_storage, VC 2003 does*/
57 #ifndef _SS_MAXSIZE
58
59 # define _SS_MAXSIZE 128
60 # define _SS_ALIGNSIZE (sizeof(__int64))
61
62 # define _SS_PAD1SIZE (_SS_ALIGNSIZE - sizeof (short))
63 # define _SS_PAD2SIZE (_SS_MAXSIZE - (sizeof (short) + _SS_PAD1SIZE \
64 + _SS_ALIGNSIZE))
65
66 struct sockaddr_storage {
67 short ss_family;
68 char __ss_pad1[_SS_PAD1SIZE];
69 __int64 __ss_align;
70 char __ss_pad2[_SS_PAD2SIZE];
71 };
72
73 typedef int socklen_t;
74
75 #define in6_addr in_addr6
76
77 #define INET_ADDRSTRLEN 22
78 #define INET6_ADDRSTRLEN 65
79
80 #endif
81
82 /*
83 * Under Windows, sockaddr_un is defined in afunix.h. Unfortunately
84 * MinGW and SDKs older than 10.0.17063.0 don't have it, so we have to
85 * define it here. Don't worry, it's portable. Windows has ironclad ABI
86 * stability guarantees which means that the definitions will *never*
87 * change.
88 */
89 #ifndef UNIX_PATH_MAX
90
91 #define UNIX_PATH_MAX 108
92
93 struct sockaddr_un
94 {
95 USHORT sun_family;
96 char sun_path[UNIX_PATH_MAX];
97 };
98
99 #endif
100
101 /*
102 * The Windows implementations of inet_ntop and inet_pton are available
103 * whenever (and only when) InetNtopA is defined.
104 * Use those implementations whenever they are available.
105 * Else use the implementations provided below.
106 */
107 #ifndef InetNtopA
108
inet_pton(int af,const char * src,void * dst)109 static int inet_pton(int af, const char *src, void *dst)
110 {
111 struct sockaddr_storage ss;
112 int size = sizeof(ss);
113 ss.ss_family = af; /* per MSDN */
114
115 if (WSAStringToAddress((char*)src, af, NULL, (struct sockaddr *)&ss, &size) != 0)
116 return 0;
117
118 switch(af) {
119 case AF_INET:
120 *(struct in_addr *)dst = ((struct sockaddr_in *)&ss)->sin_addr;
121 return 1;
122 case AF_INET6:
123 *(struct in6_addr *)dst = ((struct sockaddr_in6 *)&ss)->sin6_addr;
124 return 1;
125 default:
126 WSASetLastError(WSAEAFNOSUPPORT);
127 return -1;
128 }
129 }
130
inet_ntop(int af,const void * src,char * dst,socklen_t size)131 static const char *inet_ntop(int af, const void *src, char *dst, socklen_t size)
132 {
133 struct sockaddr_storage ss;
134 unsigned long s = size;
135
136 ZeroMemory(&ss, sizeof(ss));
137 ss.ss_family = af;
138
139 switch(af) {
140 case AF_INET:
141 ((struct sockaddr_in *)&ss)->sin_addr = *(struct in_addr *)src;
142 break;
143 case AF_INET6:
144 ((struct sockaddr_in6 *)&ss)->sin6_addr = *(struct in6_addr *)src;
145 break;
146 default:
147 return NULL;
148 }
149
150 /* cannot directly use &size because of strict aliasing rules */
151 if (WSAAddressToString((struct sockaddr *)&ss, sizeof(ss), NULL, dst, &s) != 0)
152 return NULL;
153 else
154 return dst;
155 }
156
157 #endif /* InetNtopA not defined */
158
159 #define HAS_INETPTON
160 #define HAS_INETNTOP
161 #endif
162
163 #ifdef NETWARE
164 NETDB_DEFINE_CONTEXT
165 NETINET_DEFINE_CONTEXT
166 #endif
167
168 #ifdef I_SYSUIO
169 # include <sys/uio.h>
170 #endif
171
172 #ifndef AF_NBS
173 # undef PF_NBS
174 #endif
175
176 #ifndef AF_X25
177 # undef PF_X25
178 #endif
179
180 #ifndef INADDR_NONE
181 # define INADDR_NONE 0xffffffff
182 #endif /* INADDR_NONE */
183 #ifndef INADDR_BROADCAST
184 # define INADDR_BROADCAST 0xffffffff
185 #endif /* INADDR_BROADCAST */
186 #ifndef INADDR_LOOPBACK
187 # define INADDR_LOOPBACK 0x7F000001
188 #endif /* INADDR_LOOPBACK */
189
190 #ifndef INET_ADDRSTRLEN
191 # define INET_ADDRSTRLEN 16
192 #endif
193
194 #ifndef C_ARRAY_LENGTH
195 # define C_ARRAY_LENGTH(arr) (sizeof(arr) / sizeof(*(arr)))
196 #endif /* !C_ARRAY_LENGTH */
197
198 #ifndef PERL_UNUSED_VAR
199 # define PERL_UNUSED_VAR(x) ((void)x)
200 #endif /* !PERL_UNUSED_VAR */
201
202 #ifndef PERL_UNUSED_ARG
203 # define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x)
204 #endif /* !PERL_UNUSED_ARG */
205
206 #ifndef Newx
207 # define Newx(v,n,t) New(0,v,n,t)
208 #endif /* !Newx */
209
210 #ifndef SvPVx_nolen
211 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
212 # define SvPVx_nolen(sv) ({SV *_sv = (sv); SvPV_nolen(_sv); })
213 #else /* __GNUC__ */
214 # define SvPVx_nolen(sv) ((PL_Sv = (sv)), SvPV_nolen(PL_Sv))
215 #endif /* __GNU__ */
216 #endif /* !SvPVx_nolen */
217
218 #ifndef croak_sv
219 # define croak_sv(sv) croak("%s", SvPVx_nolen(sv))
220 #endif
221
222 #ifndef hv_stores
223 # define hv_stores(hv, keystr, val) \
224 hv_store(hv, ""keystr"", sizeof(keystr)-1, val, 0)
225 #endif /* !hv_stores */
226
227 #ifndef newSVpvn_flags
228 # define newSVpvn_flags(s,len,flags) my_newSVpvn_flags(aTHX_ s,len,flags)
my_newSVpvn_flags(pTHX_ const char * s,STRLEN len,U32 flags)229 static SV *my_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags)
230 {
231 SV *sv = newSVpvn(s, len);
232 SvFLAGS(sv) |= (flags & SVf_UTF8);
233 return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
234 }
235 #endif /* !newSVpvn_flags */
236
237 #ifndef SvPVbyte_nomg
238 # define SvPVbyte_nomg SvPV
239 #endif /* !SvPVbyte_nomg */
240
241 #ifndef HEK_FLAGS
242 # define HEK_FLAGS(hek) 0
243 # define HVhek_UTF8 1
244 #endif /* !HEK_FLAGS */
245
246 #ifndef hv_common
247 /* These magic numbers are arbitrarily chosen (copied from perl core in fact)
248 * and only have to match between this definition and the code that uses them
249 */
250 # define HV_FETCH_ISSTORE 0x04
251 # define HV_FETCH_LVALUE 0x10
252 # define hv_common(hv, keysv, key, klen, flags, act, val, hash) \
253 my_hv_common(aTHX_ hv, keysv, key, klen, flags, act, val, hash)
my_hv_common(pTHX_ HV * hv,SV * keysv,const char * key,STRLEN klen,int flags,int act,SV * val,U32 hash)254 static void *my_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
255 int flags, int act, SV *val, U32 hash)
256 {
257 /*
258 * This only handles the usage actually made by the code
259 * generated by ExtUtils::Constant. EU:C really ought to arrange
260 * portability of its generated code itself.
261 */
262 if (!keysv) {
263 keysv = sv_2mortal(newSVpvn(key, klen));
264 if (flags & HVhek_UTF8)
265 SvUTF8_on(keysv);
266 }
267 if (act == HV_FETCH_LVALUE) {
268 return (void*)hv_fetch_ent(hv, keysv, 1, hash);
269 } else if (act == HV_FETCH_ISSTORE) {
270 return (void*)hv_store_ent(hv, keysv, val, hash);
271 } else {
272 croak("panic: my_hv_common: act=0x%x", act);
273 }
274 }
275 #endif /* !hv_common */
276
277 #ifndef hv_common_key_len
278 # define hv_common_key_len(hv, key, kl, act, val, hash) \
279 my_hv_common_key_len(aTHX_ hv, key, kl, act, val, hash)
my_hv_common_key_len(pTHX_ HV * hv,const char * key,I32 kl,int act,SV * val,U32 hash)280 static void *my_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 kl,
281 int act, SV *val, U32 hash)
282 {
283 STRLEN klen;
284 int flags;
285 if (kl < 0) {
286 klen = -kl;
287 flags = HVhek_UTF8;
288 } else {
289 klen = kl;
290 flags = 0;
291 }
292 return hv_common(hv, NULL, key, klen, flags, act, val, hash);
293 }
294 #endif /* !hv_common_key_len */
295
296 #ifndef mPUSHi
297 # define mPUSHi(i) sv_setiv_mg(PUSHs(sv_newmortal()), (IV)(i))
298 #endif /* !mPUSHi */
299 #ifndef mPUSHp
300 # define mPUSHp(p,l) sv_setpvn_mg(PUSHs(sv_newmortal()), (p), (l))
301 #endif /* !mPUSHp */
302 #ifndef mPUSHs
303 # define mPUSHs(s) PUSHs(sv_2mortal(s))
304 #endif /* !mPUSHs */
305
306 #ifndef G_LIST
307 # define G_LIST G_ARRAY
308 #endif /* !G_LIST */
309
310 #ifndef CvCONST_on
311 # undef newCONSTSUB
312 # define newCONSTSUB(stash, name, val) my_newCONSTSUB(aTHX_ stash, name, val)
my_newCONSTSUB(pTHX_ HV * stash,char * name,SV * val)313 static CV *my_newCONSTSUB(pTHX_ HV *stash, char *name, SV *val)
314 {
315 /*
316 * This has to satisfy code generated by ExtUtils::Constant.
317 * It depends on the 5.8+ layout of constant subs. It has
318 * two calls to newCONSTSUB(): one for real constants, and one
319 * for undefined constants. In the latter case, it turns the
320 * initially-generated constant subs into something else, and
321 * it needs the return value from newCONSTSUB() which Perl 5.6
322 * doesn't provide.
323 */
324 GV *gv;
325 CV *cv;
326 Perl_newCONSTSUB(aTHX_ stash, name, val);
327 ENTER;
328 SAVESPTR(PL_curstash);
329 PL_curstash = stash;
330 gv = gv_fetchpv(name, 0, SVt_PVCV);
331 cv = GvCV(gv);
332 LEAVE;
333 CvXSUBANY(cv).any_ptr = &PL_sv_undef;
334 return cv;
335 }
336 # define CvCONST_off(cv) my_CvCONST_off(aTHX_ cv)
my_CvCONST_off(pTHX_ CV * cv)337 static void my_CvCONST_off(pTHX_ CV *cv)
338 {
339 op_free(CvROOT(cv));
340 CvROOT(cv) = NULL;
341 CvSTART(cv) = NULL;
342 }
343 #endif /* !CvCONST_on */
344
345 #ifndef HAS_INET_ATON
346
347 /*
348 * Check whether "cp" is a valid ascii representation
349 * of an Internet address and convert to a binary address.
350 * Returns 1 if the address is valid, 0 if not.
351 * This replaces inet_addr, the return value from which
352 * cannot distinguish between failure and a local broadcast address.
353 */
354 static int
my_inet_aton(const char * cp,struct in_addr * addr)355 my_inet_aton(const char *cp, struct in_addr *addr)
356 {
357 dTHX;
358 U32 val;
359 int base;
360 char c;
361 int nparts;
362 const char *s;
363 unsigned int parts[4];
364 unsigned int *pp = parts;
365
366 if (!cp || !*cp)
367 return 0;
368 for (;;) {
369 /*
370 * Collect number up to ".".
371 * Values are specified as for C:
372 * 0x=hex, 0=octal, other=decimal.
373 */
374 val = 0; base = 10;
375 if (*cp == '0') {
376 if (*++cp == 'x' || *cp == 'X')
377 base = 16, cp++;
378 else
379 base = 8;
380 }
381 while ((c = *cp) != '\0') {
382 if (isDIGIT(c)) {
383 val = (val * base) + (c - '0');
384 cp++;
385 continue;
386 }
387 if (base == 16 && (s=strchr(PL_hexdigit,c))) {
388 val = (val << 4) +
389 ((s - PL_hexdigit) & 15);
390 cp++;
391 continue;
392 }
393 break;
394 }
395 if (*cp == '.') {
396 /*
397 * Internet format:
398 * a.b.c.d
399 * a.b.c (with c treated as 16-bits)
400 * a.b (with b treated as 24 bits)
401 */
402 if (pp >= parts + 3 || val > 0xff)
403 return 0;
404 *pp++ = val, cp++;
405 } else
406 break;
407 }
408 /*
409 * Check for trailing characters.
410 */
411 if (*cp && !isSPACE(*cp))
412 return 0;
413 /*
414 * Concoct the address according to
415 * the number of parts specified.
416 */
417 nparts = pp - parts + 1; /* force to an int for switch() */
418 switch (nparts) {
419
420 case 1: /* a -- 32 bits */
421 break;
422
423 case 2: /* a.b -- 8.24 bits */
424 if (val > 0xffffff)
425 return 0;
426 val |= parts[0] << 24;
427 break;
428
429 case 3: /* a.b.c -- 8.8.16 bits */
430 if (val > 0xffff)
431 return 0;
432 val |= (parts[0] << 24) | (parts[1] << 16);
433 break;
434
435 case 4: /* a.b.c.d -- 8.8.8.8 bits */
436 if (val > 0xff)
437 return 0;
438 val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
439 break;
440 }
441 addr->s_addr = htonl(val);
442 return 1;
443 }
444
445 #undef inet_aton
446 #define inet_aton my_inet_aton
447
448 #endif /* ! HAS_INET_ATON */
449
450 /* These are not gni() constants; they're extensions for the perl API */
451 /* The definitions in Socket.pm and Socket.xs must match */
452 #define NIx_NOHOST (1 << 0)
453 #define NIx_NOSERV (1 << 1)
454
455 /* On Windows, ole2.h defines a macro called "interface". We don't need that,
456 * and it will complicate the variables in pack_ip_mreq() etc. (RT87389)
457 */
458 #undef interface
459
460 /* STRUCT_OFFSET should have come from from perl.h, but if not,
461 * roll our own (not using offsetof() since that is C99). */
462 #ifndef STRUCT_OFFSET
463 # define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m))
464 #endif
465
466 static SV *
not_here(const char * s)467 not_here(const char *s)
468 {
469 croak("Socket::%s not implemented on this architecture", s);
470 return NULL;
471 }
472
473 #define PERL_IN_ADDR_S_ADDR_SIZE 4
474
475 /*
476 * Bad assumptions possible here.
477 *
478 * Bad Assumption 1: struct in_addr has no other fields
479 * than the s_addr (which is the field we care about
480 * in here, really). However, we can be fed either 4-byte
481 * addresses (from pack("N", ...), or va.b.c.d, or ...),
482 * or full struct in_addrs (from e.g. pack_sockaddr_in()),
483 * which may or may not be 4 bytes in size.
484 *
485 * Bad Assumption 2: the s_addr field is a simple type
486 * (such as an int, u_int32_t). It can be a bit field,
487 * in which case using & (address-of) on it or taking sizeof()
488 * wouldn't go over too well. (Those are not attempted
489 * now but in case someone thinks to change the below code
490 * to use addr.s_addr instead of addr, you have been warned.)
491 *
492 * Bad Assumption 3: the s_addr is the first field in
493 * an in_addr, or that its bytes are the first bytes in
494 * an in_addr.
495 *
496 * These bad assumptions are wrong in UNICOS which has
497 * struct in_addr { struct { u_long st_addr:32; } s_da };
498 * #define s_addr s_da.st_addr
499 * and u_long is 64 bits.
500 *
501 * --jhi */
502
503 #include "const-c.inc"
504
505 #if defined(HAS_GETADDRINFO) && !defined(HAS_GAI_STRERROR)
gai_strerror(int err)506 static const char *gai_strerror(int err)
507 {
508 switch (err)
509 {
510 #ifdef EAI_ADDRFAMILY
511 case EAI_ADDRFAMILY:
512 return "Address family for hostname is not supported.";
513 #endif
514 #ifdef EAI_AGAIN
515 case EAI_AGAIN:
516 return "The name could not be resolved at this time.";
517 #endif
518 #ifdef EAI_BADFLAGS
519 case EAI_BADFLAGS:
520 return "The flags parameter has an invalid value.";
521 #endif
522 #ifdef EAI_FAIL
523 case EAI_FAIL:
524 return "A non-recoverable error occurred while resolving the name.";
525 #endif
526 #ifdef EAI_FAMILY
527 case EAI_FAMILY:
528 return "The address family was not recognized or length is invalid.";
529 #endif
530 #ifdef EAI_MEMORY
531 case EAI_MEMORY:
532 return "A memory allocation failure occurred.";
533 #endif
534 #ifdef EAI_NODATA
535 case EAI_NODATA:
536 return "No address is associated with the hostname.";
537 #endif
538 #ifdef EAI_NONAME
539 case EAI_NONAME:
540 return "The name does not resolve for the supplied parameters.";
541 #endif
542 #ifdef EAI_OVERFLOW
543 case EAI_OVERFLOW:
544 return "An argument buffer overflowed.";
545 #endif
546 #ifdef EAI_SERVICE
547 case EAI_SERVICE:
548 return "The service parameter was not recognized for the specified socket type.";
549 #endif
550 #ifdef EAI_SOCKTYPE
551 case EAI_SOCKTYPE:
552 return "The specified socket type was not recognized.";
553 #endif
554 #ifdef EAI_SYSTEM
555 case EAI_SYSTEM:
556 return "A system error occurred - see errno.";
557 #endif
558 default:
559 return "Unknown error in getaddrinfo().";
560 }
561 }
562 #endif
563
564 #ifdef HAS_GETADDRINFO
err_to_SV(pTHX_ int err)565 static SV *err_to_SV(pTHX_ int err)
566 {
567 SV *ret = sv_newmortal();
568 (void) SvUPGRADE(ret, SVt_PVNV);
569
570 if(err) {
571 const char *error = gai_strerror(err);
572 sv_setpv(ret, error);
573 }
574 else {
575 sv_setpv(ret, "");
576 }
577
578 SvIV_set(ret, err); SvIOK_on(ret);
579
580 return ret;
581 }
582
xs_getaddrinfo(pTHX_ CV * cv)583 static void xs_getaddrinfo(pTHX_ CV *cv)
584 {
585 dXSARGS;
586
587 SV *host;
588 SV *service;
589 SV *hints;
590
591 char *hostname = NULL;
592 char *servicename = NULL;
593 STRLEN len;
594 struct addrinfo hints_s;
595 struct addrinfo *res;
596 struct addrinfo *res_iter;
597 int err;
598 int n_res;
599
600 PERL_UNUSED_ARG(cv);
601 if(items > 3)
602 croak("Usage: Socket::getaddrinfo(host, service, hints)");
603
604 SP -= items;
605
606 if(items < 1)
607 host = &PL_sv_undef;
608 else
609 host = ST(0);
610
611 if(items < 2)
612 service = &PL_sv_undef;
613 else
614 service = ST(1);
615
616 if(items < 3)
617 hints = NULL;
618 else
619 hints = ST(2);
620
621 SvGETMAGIC(host);
622 if(SvOK(host)) {
623 hostname = SvPVbyte_nomg(host, len);
624 if (!len)
625 hostname = NULL;
626 }
627
628 SvGETMAGIC(service);
629 if(SvOK(service)) {
630 servicename = SvPVbyte_nomg(service, len);
631 if (!len)
632 servicename = NULL;
633 }
634
635 Zero(&hints_s, sizeof(hints_s), char);
636 hints_s.ai_family = PF_UNSPEC;
637
638 if(hints && SvOK(hints)) {
639 HV *hintshash;
640 SV **valp;
641
642 if(!SvROK(hints) || SvTYPE(SvRV(hints)) != SVt_PVHV)
643 croak("hints is not a HASH reference");
644
645 hintshash = (HV*)SvRV(hints);
646
647 if((valp = hv_fetch(hintshash, "flags", 5, 0)) != NULL && SvOK(*valp))
648 hints_s.ai_flags = SvIV(*valp);
649 if((valp = hv_fetch(hintshash, "family", 6, 0)) != NULL && SvOK(*valp))
650 hints_s.ai_family = SvIV(*valp);
651 if((valp = hv_fetch(hintshash, "socktype", 8, 0)) != NULL && SvOK(*valp))
652 hints_s.ai_socktype = SvIV(*valp);
653 if((valp = hv_fetch(hintshash, "protocol", 8, 0)) != NULL && SvOK(*valp))
654 hints_s.ai_protocol = SvIV(*valp);
655 }
656
657 err = getaddrinfo(hostname, servicename, &hints_s, &res);
658
659 XPUSHs(err_to_SV(aTHX_ err));
660
661 if(err)
662 XSRETURN(1);
663
664 n_res = 0;
665 for(res_iter = res; res_iter; res_iter = res_iter->ai_next) {
666 HV *res_hv = newHV();
667
668 (void)hv_stores(res_hv, "family", newSViv(res_iter->ai_family));
669 (void)hv_stores(res_hv, "socktype", newSViv(res_iter->ai_socktype));
670 (void)hv_stores(res_hv, "protocol", newSViv(res_iter->ai_protocol));
671
672 (void)hv_stores(res_hv, "addr", newSVpvn((char*)res_iter->ai_addr, res_iter->ai_addrlen));
673
674 if(res_iter->ai_canonname)
675 (void)hv_stores(res_hv, "canonname", newSVpv(res_iter->ai_canonname, 0));
676 else
677 (void)hv_stores(res_hv, "canonname", newSV(0));
678
679 XPUSHs(sv_2mortal(newRV_noinc((SV*)res_hv)));
680 n_res++;
681 }
682
683 freeaddrinfo(res);
684
685 XSRETURN(1 + n_res);
686 }
687 #endif
688
689 #ifdef HAS_GETNAMEINFO
xs_getnameinfo(pTHX_ CV * cv)690 static void xs_getnameinfo(pTHX_ CV *cv)
691 {
692 dXSARGS;
693
694 SV *addr;
695 int flags;
696 int xflags;
697
698 char host[1024];
699 char serv[256];
700 char *sa; /* we'll cast to struct sockaddr * when necessary */
701 STRLEN addr_len;
702 int err;
703
704 int want_host, want_serv;
705
706 PERL_UNUSED_ARG(cv);
707 if(items < 1 || items > 3)
708 croak("Usage: Socket::getnameinfo(addr, flags=0, xflags=0)");
709
710 SP -= items;
711
712 addr = ST(0);
713 SvGETMAGIC(addr);
714
715 if(items < 2)
716 flags = 0;
717 else
718 flags = SvIV(ST(1));
719
720 if(items < 3)
721 xflags = 0;
722 else
723 xflags = SvIV(ST(2));
724
725 want_host = !(xflags & NIx_NOHOST);
726 want_serv = !(xflags & NIx_NOSERV);
727
728 if(!SvPOKp(addr))
729 croak("addr is not a string");
730
731 addr_len = SvCUR(addr);
732
733 /* We need to ensure the sockaddr is aligned, because a random SvPV might
734 * not be due to SvOOK */
735 Newx(sa, addr_len, char);
736 Copy(SvPV_nolen(addr), sa, addr_len, char);
737 #ifdef HAS_SOCKADDR_SA_LEN
738 ((struct sockaddr *)sa)->sa_len = addr_len;
739 #endif
740
741 err = getnameinfo((struct sockaddr *)sa, addr_len,
742 #ifdef OS390 /* This OS requires both parameters to be non-NULL */
743 host, sizeof(host),
744 serv, sizeof(serv),
745 #else
746 want_host ? host : NULL, want_host ? sizeof(host) : 0,
747 want_serv ? serv : NULL, want_serv ? sizeof(serv) : 0,
748 #endif
749 flags);
750
751 Safefree(sa);
752
753 XPUSHs(err_to_SV(aTHX_ err));
754
755 if(err)
756 XSRETURN(1);
757
758 XPUSHs(want_host ? sv_2mortal(newSVpv(host, 0)) : &PL_sv_undef);
759 XPUSHs(want_serv ? sv_2mortal(newSVpv(serv, 0)) : &PL_sv_undef);
760
761 XSRETURN(3);
762 }
763 #endif
764
765 MODULE = Socket PACKAGE = Socket
766
767 INCLUDE: const-xs.inc
768
769 BOOT:
770 #ifdef HAS_GETADDRINFO
771 newXS("Socket::getaddrinfo", xs_getaddrinfo, __FILE__);
772 #endif
773 #ifdef HAS_GETNAMEINFO
774 newXS("Socket::getnameinfo", xs_getnameinfo, __FILE__);
775 #endif
776
777 void
inet_aton(host)778 inet_aton(host)
779 char * host
780 CODE:
781 {
782 #ifdef HAS_GETADDRINFO
783 struct addrinfo *res;
784 struct addrinfo hints = {0};
785 hints.ai_family = AF_INET;
786 if (!getaddrinfo(host, NULL, &hints, &res)) {
787 ST(0) = sv_2mortal(newSVpvn(
788 (char *)&(((struct sockaddr_in *)res->ai_addr)->sin_addr.s_addr),
789 4));
790 freeaddrinfo(res);
791 XSRETURN(1);
792 }
793 #else
794 struct in_addr ip_address;
795 struct hostent * phe;
796 if ((*host != '\0') && inet_aton(host, &ip_address)) {
797 ST(0) = sv_2mortal(newSVpvn((char *)&ip_address, sizeof(ip_address)));
798 XSRETURN(1);
799 }
800 #ifdef HAS_GETHOSTBYNAME
801 /* gethostbyname is not thread-safe */
802 phe = gethostbyname(host);
803 if (phe && phe->h_addrtype == AF_INET && phe->h_length == 4) {
804 ST(0) = sv_2mortal(newSVpvn((char *)phe->h_addr, phe->h_length));
805 XSRETURN(1);
806 }
807 #endif /* HAS_GETHOSTBYNAME */
808 #endif /* HAS_GETADDRINFO */
809 XSRETURN_UNDEF;
810 }
811
812 void
inet_ntoa(ip_address_sv)813 inet_ntoa(ip_address_sv)
814 SV * ip_address_sv
815 CODE:
816 {
817 STRLEN addrlen;
818 struct in_addr addr;
819 char * ip_address;
820 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1))
821 croak("Wide character in %s", "Socket::inet_ntoa");
822 ip_address = SvPVbyte(ip_address_sv, addrlen);
823 if (addrlen == sizeof(addr) || addrlen == 4)
824 addr.s_addr =
825 (unsigned long)(ip_address[0] & 0xFF) << 24 |
826 (unsigned long)(ip_address[1] & 0xFF) << 16 |
827 (unsigned long)(ip_address[2] & 0xFF) << 8 |
828 (unsigned long)(ip_address[3] & 0xFF);
829 else
830 croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf,
831 "Socket::inet_ntoa", (UV)addrlen, (UV)sizeof(addr));
832 /* We could use inet_ntoa() but that is broken
833 * in HP-UX + GCC + 64bitint (returns "0.0.0.0"),
834 * so let's use this sprintf() workaround everywhere.
835 * This is also more threadsafe than using inet_ntoa(). */
836 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "%d.%d.%d.%d", /* IPv6? */
837 (int)((addr.s_addr >> 24) & 0xFF),
838 (int)((addr.s_addr >> 16) & 0xFF),
839 (int)((addr.s_addr >> 8) & 0xFF),
840 (int)( addr.s_addr & 0xFF)));
841 }
842
843 void
844 sockaddr_family(sockaddr)
845 SV * sockaddr
846 PREINIT:
847 STRLEN sockaddr_len;
848 char *sockaddr_pv = SvPVbyte(sockaddr, sockaddr_len);
849 CODE:
850 if (sockaddr_len < STRUCT_OFFSET(struct sockaddr, sa_data))
851 croak("Bad arg length for %s, length is %" UVuf ", should be at least %" UVuf,
852 "Socket::sockaddr_family", (UV)sockaddr_len,
853 (UV)STRUCT_OFFSET(struct sockaddr, sa_data));
854 ST(0) = sv_2mortal(newSViv(((struct sockaddr*)sockaddr_pv)->sa_family));
855
856 void
pack_sockaddr_un(pathname)857 pack_sockaddr_un(pathname)
858 SV * pathname
859 CODE:
860 {
861 #if defined(I_SYS_UN) || defined(WIN32)
862 struct sockaddr_un sun_ad; /* fear using sun */
863 STRLEN len;
864 char * pathname_pv;
865 int addr_len;
866
867 if (!SvOK(pathname))
868 croak("Undefined path for %s", "Socket::pack_sockaddr_un");
869
870 Zero(&sun_ad, sizeof(sun_ad), char);
871 sun_ad.sun_family = AF_UNIX;
872 pathname_pv = SvPVbyte(pathname,len);
873 if (len > sizeof(sun_ad.sun_path)) {
874 warn("Path length (%" UVuf ") is longer than maximum supported length"
875 " (%" UVuf ") and will be truncated",
876 (UV)len, (UV)sizeof(sun_ad.sun_path));
877 len = sizeof(sun_ad.sun_path);
878 }
879 # ifdef OS2 /* Name should start with \socket\ and contain backslashes! */
880 {
881 int off;
882 char *s, *e;
883
884 if (pathname_pv[0] != '/' && pathname_pv[0] != '\\')
885 croak("Relative UNIX domain socket name '%s' unsupported",
886 pathname_pv);
887 else if (len < 8
888 || pathname_pv[7] != '/' && pathname_pv[7] != '\\'
889 || !strnicmp(pathname_pv + 1, "socket", 6))
890 off = 7;
891 else
892 off = 0; /* Preserve names starting with \socket\ */
893 Copy("\\socket", sun_ad.sun_path, off, char);
894 Copy(pathname_pv, sun_ad.sun_path + off, len, char);
895
896 s = sun_ad.sun_path + off - 1;
897 e = s + len + 1;
898 while (++s < e)
899 if (*s = '/')
900 *s = '\\';
901 }
902 # else /* !( defined OS2 ) */
903 Copy(pathname_pv, sun_ad.sun_path, len, char);
904 # endif
905 if (0) not_here("dummy");
906 if (len > 1 && sun_ad.sun_path[0] == '\0') {
907 /* Linux-style abstract-namespace socket.
908 * The name is not a file name, but an array of arbitrary
909 * character, starting with \0 and possibly including \0s,
910 * therefore the length of the structure must denote the
911 * end of that character array */
912 addr_len = (char *)&(sun_ad.sun_path) - (char *)&sun_ad + len;
913 } else {
914 addr_len = sizeof(sun_ad);
915 }
916 # ifdef HAS_SOCKADDR_SA_LEN
917 sun_ad.sun_len = addr_len;
918 # endif
919 ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, addr_len));
920 #else
921 ST(0) = not_here("pack_sockaddr_un");
922 #endif
923 }
924
925 void
unpack_sockaddr_un(sun_sv)926 unpack_sockaddr_un(sun_sv)
927 SV * sun_sv
928 CODE:
929 {
930 #if defined(I_SYS_UN) || defined(WIN32)
931 struct sockaddr_un addr;
932 STRLEN sockaddrlen;
933 char * sun_ad;
934 int addr_len = 0;
935 if (!SvOK(sun_sv))
936 croak("Undefined address for %s", "Socket::unpack_sockaddr_un");
937 sun_ad = SvPVbyte(sun_sv,sockaddrlen);
938 # if defined(__linux__) || defined(__CYGWIN__) || defined(sun) || defined(HAS_SOCKADDR_SA_LEN)
939 /* On Linux, Cygwin, Solaris or *BSD sockaddrlen on sockets returned by accept,
940 * recvfrom, getpeername and getsockname is not equal to sizeof(addr). */
941 if (sockaddrlen < sizeof(addr)) {
942 Copy(sun_ad, &addr, sockaddrlen, char);
943 Zero(((char*)&addr) + sockaddrlen, sizeof(addr) - sockaddrlen, char);
944 } else {
945 Copy(sun_ad, &addr, sizeof(addr), char);
946 }
947 # ifdef HAS_SOCKADDR_SA_LEN
948 /* In this case, sun_len must be checked */
949 if (sockaddrlen != addr.sun_len)
950 croak("Invalid arg sun_len field for %s, length is %" UVuf ", but sun_len is %" UVuf,
951 "Socket::unpack_sockaddr_un", (UV)sockaddrlen, (UV)addr.sun_len);
952 # endif
953 # else
954 if (sockaddrlen != sizeof(addr))
955 croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf,
956 "Socket::unpack_sockaddr_un", (UV)sockaddrlen, (UV)sizeof(addr));
957 Copy(sun_ad, &addr, sizeof(addr), char);
958 # endif
959
960 if (addr.sun_family != AF_UNIX)
961 croak("Bad address family for %s, got %d, should be %d",
962 "Socket::unpack_sockaddr_un", addr.sun_family, AF_UNIX);
963 # ifdef __linux__
964 if (addr.sun_path[0] == '\0') {
965 /* Linux-style abstract socket address begins with a nul
966 * and can contain nuls. */
967 addr_len = (char *)&addr - (char *)&(addr.sun_path) + sockaddrlen;
968 } else
969 # endif
970 {
971 # if defined(HAS_SOCKADDR_SA_LEN)
972 /* On *BSD sun_path not always ends with a '\0' */
973 int maxlen = addr.sun_len - 2; /* should use STRUCT_OFFSET(struct sockaddr_un, sun_path) instead of 2 */
974 if (maxlen > (int)sizeof(addr.sun_path))
975 maxlen = (int)sizeof(addr.sun_path);
976 # else
977 const int maxlen = (int)sizeof(addr.sun_path);
978 # endif
979 while (addr_len < maxlen && addr.sun_path[addr_len])
980 addr_len++;
981 }
982
983 ST(0) = sv_2mortal(newSVpvn(addr.sun_path, addr_len));
984 #else
985 ST(0) = not_here("unpack_sockaddr_un");
986 #endif
987 }
988
989 void
pack_sockaddr_in(port_sv,ip_address_sv)990 pack_sockaddr_in(port_sv, ip_address_sv)
991 SV * port_sv
992 SV * ip_address_sv
993 CODE:
994 {
995 struct sockaddr_in sin;
996 struct in_addr addr;
997 STRLEN addrlen;
998 unsigned short port = 0;
999 char * ip_address;
1000 if (SvOK(port_sv)) {
1001 port = SvUV(port_sv);
1002 if (SvUV(port_sv) > 0xFFFF)
1003 warn("Port number above 0xFFFF, will be truncated to %d for %s",
1004 port, "Socket::pack_sockaddr_in");
1005 }
1006 if (!SvOK(ip_address_sv))
1007 croak("Undefined address for %s", "Socket::pack_sockaddr_in");
1008 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1))
1009 croak("Wide character in %s", "Socket::pack_sockaddr_in");
1010 ip_address = SvPVbyte(ip_address_sv, addrlen);
1011 if (addrlen == sizeof(addr) || addrlen == 4)
1012 addr.s_addr =
1013 (unsigned int)(ip_address[0] & 0xFF) << 24 |
1014 (unsigned int)(ip_address[1] & 0xFF) << 16 |
1015 (unsigned int)(ip_address[2] & 0xFF) << 8 |
1016 (unsigned int)(ip_address[3] & 0xFF);
1017 else
1018 croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf,
1019 "Socket::pack_sockaddr_in", (UV)addrlen, (UV)sizeof(addr));
1020 Zero(&sin, sizeof(sin), char);
1021 sin.sin_family = AF_INET;
1022 sin.sin_port = htons(port);
1023 sin.sin_addr.s_addr = htonl(addr.s_addr);
1024 # ifdef HAS_SOCKADDR_SA_LEN
1025 sin.sin_len = sizeof(sin);
1026 # endif
1027 ST(0) = sv_2mortal(newSVpvn((char *)&sin, sizeof(sin)));
1028 }
1029
1030 void
unpack_sockaddr_in(sin_sv)1031 unpack_sockaddr_in(sin_sv)
1032 SV * sin_sv
1033 PPCODE:
1034 {
1035 STRLEN sockaddrlen;
1036 struct sockaddr_in addr;
1037 SV *ip_address_sv;
1038 char * sin;
1039 if (!SvOK(sin_sv))
1040 croak("Undefined address for %s", "Socket::unpack_sockaddr_in");
1041 sin = SvPVbyte(sin_sv,sockaddrlen);
1042 if (sockaddrlen != sizeof(addr)) {
1043 croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf,
1044 "Socket::unpack_sockaddr_in", (UV)sockaddrlen, (UV)sizeof(addr));
1045 }
1046 Copy(sin, &addr, sizeof(addr), char);
1047 if (addr.sin_family != AF_INET) {
1048 croak("Bad address family for %s, got %d, should be %d",
1049 "Socket::unpack_sockaddr_in", addr.sin_family, AF_INET);
1050 }
1051 ip_address_sv = newSVpvn((char *)&addr.sin_addr, sizeof(addr.sin_addr));
1052
1053 if(GIMME_V == G_LIST) {
1054 EXTEND(SP, 2);
1055 mPUSHi(ntohs(addr.sin_port));
1056 mPUSHs(ip_address_sv);
1057 }
1058 else {
1059 mPUSHs(ip_address_sv);
1060 }
1061 }
1062
1063 void
1064 pack_sockaddr_in6(port_sv, sin6_addr, scope_id=0, flowinfo=0)
1065 SV * port_sv
1066 SV * sin6_addr
1067 unsigned long scope_id
1068 unsigned long flowinfo
1069 CODE:
1070 {
1071 #ifdef HAS_SOCKADDR_IN6
1072 unsigned short port = 0;
1073 struct sockaddr_in6 sin6;
1074 char * addrbytes;
1075 STRLEN addrlen;
1076 if (SvOK(port_sv)) {
1077 port = SvUV(port_sv);
1078 if (SvUV(port_sv) > 0xFFFF)
1079 warn("Port number above 0xFFFF, will be truncated to %d for %s",
1080 port, "Socket::pack_sockaddr_in6");
1081 }
1082 if (!SvOK(sin6_addr))
1083 croak("Undefined address for %s", "Socket::pack_sockaddr_in6");
1084 if (DO_UTF8(sin6_addr) && !sv_utf8_downgrade(sin6_addr, 1))
1085 croak("Wide character in %s", "Socket::pack_sockaddr_in6");
1086 addrbytes = SvPVbyte(sin6_addr, addrlen);
1087 if (addrlen != sizeof(sin6.sin6_addr))
1088 croak("Bad arg length %s, length is %" UVuf ", should be %" UVuf,
1089 "Socket::pack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6.sin6_addr));
1090 Zero(&sin6, sizeof(sin6), char);
1091 sin6.sin6_family = AF_INET6;
1092 sin6.sin6_port = htons(port);
1093 sin6.sin6_flowinfo = htonl(flowinfo);
1094 Copy(addrbytes, &sin6.sin6_addr, sizeof(sin6.sin6_addr), char);
1095 # ifdef HAS_SIN6_SCOPE_ID
1096 sin6.sin6_scope_id = scope_id;
1097 # else
1098 if (scope_id != 0)
1099 warn("%s cannot represent non-zero scope_id %d",
1100 "Socket::pack_sockaddr_in6", scope_id);
1101 # endif
1102 # ifdef HAS_SOCKADDR_SA_LEN
1103 sin6.sin6_len = sizeof(sin6);
1104 # endif
1105 ST(0) = sv_2mortal(newSVpvn((char *)&sin6, sizeof(sin6)));
1106 #else
1107 PERL_UNUSED_VAR(port_sv);
1108 PERL_UNUSED_VAR(sin6_addr);
1109 ST(0) = not_here("pack_sockaddr_in6");
1110 #endif
1111 }
1112
1113 void
unpack_sockaddr_in6(sin6_sv)1114 unpack_sockaddr_in6(sin6_sv)
1115 SV * sin6_sv
1116 PPCODE:
1117 {
1118 #ifdef HAS_SOCKADDR_IN6
1119 STRLEN addrlen;
1120 struct sockaddr_in6 sin6;
1121 char * addrbytes;
1122 SV *ip_address_sv;
1123 if (!SvOK(sin6_sv))
1124 croak("Undefined address for %s", "Socket::unpack_sockaddr_in6");
1125 addrbytes = SvPVbyte(sin6_sv, addrlen);
1126 if (addrlen != sizeof(sin6))
1127 croak("Bad arg length for %s, length is %" UVuf
1128 ", should be %" UVuf,
1129 "Socket::unpack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6));
1130 Copy(addrbytes, &sin6, sizeof(sin6), char);
1131 if (sin6.sin6_family != AF_INET6)
1132 croak("Bad address family for %s, got %d, should be %d",
1133 "Socket::unpack_sockaddr_in6", sin6.sin6_family, AF_INET6);
1134 ip_address_sv = newSVpvn((char *)&sin6.sin6_addr, sizeof(sin6.sin6_addr));
1135
1136 if(GIMME_V == G_LIST) {
1137 EXTEND(SP, 4);
1138 mPUSHi(ntohs(sin6.sin6_port));
1139 mPUSHs(ip_address_sv);
1140 # ifdef HAS_SIN6_SCOPE_ID
1141 mPUSHi(sin6.sin6_scope_id);
1142 # else
1143 mPUSHi(0);
1144 # endif
1145 mPUSHi(ntohl(sin6.sin6_flowinfo));
1146 }
1147 else {
1148 mPUSHs(ip_address_sv);
1149 }
1150 #else
1151 PERL_UNUSED_VAR(sin6_sv);
1152 ST(0) = not_here("pack_sockaddr_in6");
1153 #endif
1154 }
1155
1156 void
inet_ntop(af,ip_address_sv)1157 inet_ntop(af, ip_address_sv)
1158 int af
1159 SV * ip_address_sv
1160 CODE:
1161 {
1162 #ifdef HAS_INETNTOP
1163 STRLEN addrlen;
1164 #ifdef AF_INET6
1165 struct in6_addr addr;
1166 char str[INET6_ADDRSTRLEN];
1167 #else
1168 struct in_addr addr;
1169 char str[INET_ADDRSTRLEN];
1170 #endif
1171 char *ip_address;
1172
1173 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1))
1174 croak("Wide character in %s", "Socket::inet_ntop");
1175
1176 ip_address = SvPVbyte(ip_address_sv, addrlen);
1177
1178 switch(af) {
1179 case AF_INET:
1180 if(addrlen != 4)
1181 croak("Bad address length for Socket::inet_ntop on AF_INET;"
1182 " got %" UVuf ", should be 4", (UV)addrlen);
1183 break;
1184 #ifdef AF_INET6
1185 case AF_INET6:
1186 if(addrlen != 16)
1187 croak("Bad address length for Socket::inet_ntop on AF_INET6;"
1188 " got %" UVuf ", should be 16", (UV)addrlen);
1189 break;
1190 #endif
1191 default:
1192 #ifdef AF_INET6
1193 # define WANT_FAMILY "either AF_INET or AF_INET6"
1194 #else
1195 # define WANT_FAMILY "AF_INET"
1196 #endif
1197 croak("Bad address family for %s, got %d, should be " WANT_FAMILY,
1198 "Socket::inet_ntop", af);
1199 #undef WANT_FAMILY
1200 }
1201
1202 if(addrlen < sizeof(addr)) {
1203 Copy(ip_address, &addr, addrlen, char);
1204 Zero(((char*)&addr) + addrlen, sizeof(addr) - addrlen, char);
1205 }
1206 else {
1207 Copy(ip_address, &addr, sizeof addr, char);
1208 }
1209 inet_ntop(af, &addr, str, sizeof str);
1210
1211 ST(0) = sv_2mortal(newSVpvn(str, strlen(str)));
1212 #else
1213 PERL_UNUSED_VAR(af);
1214 PERL_UNUSED_VAR(ip_address_sv);
1215 ST(0) = not_here("inet_ntop");
1216 #endif
1217 }
1218
1219 void
inet_pton(af,host)1220 inet_pton(af, host)
1221 int af
1222 const char * host
1223 CODE:
1224 {
1225 #ifdef HAS_INETPTON
1226 int ok;
1227 int addrlen = 0;
1228 #ifdef AF_INET6
1229 struct in6_addr ip_address;
1230 #else
1231 struct in_addr ip_address;
1232 #endif
1233
1234 switch(af) {
1235 case AF_INET:
1236 addrlen = 4;
1237 break;
1238 #ifdef AF_INET6
1239 case AF_INET6:
1240 addrlen = 16;
1241 break;
1242 #endif
1243 default:
1244 #ifdef AF_INET6
1245 # define WANT_FAMILY "either AF_INET or AF_INET6"
1246 #else
1247 # define WANT_FAMILY "AF_INET"
1248 #endif
1249 croak("Bad address family for %s, got %d, should be " WANT_FAMILY, "Socket::inet_pton", af);
1250 #undef WANT_FAMILY
1251 }
1252 ok = (*host != '\0') && inet_pton(af, host, &ip_address);
1253
1254 ST(0) = sv_newmortal();
1255 if (ok) {
1256 sv_setpvn( ST(0), (char *)&ip_address, addrlen);
1257 }
1258 #else
1259 PERL_UNUSED_VAR(af);
1260 PERL_UNUSED_VAR(host);
1261 ST(0) = not_here("inet_pton");
1262 #endif
1263 }
1264
1265 void
1266 pack_ip_mreq(multiaddr, interface=&PL_sv_undef)
1267 SV * multiaddr
1268 SV * interface
1269 CODE:
1270 {
1271 #ifdef HAS_IP_MREQ
1272 struct ip_mreq mreq;
1273 char * multiaddrbytes;
1274 char * interfacebytes;
1275 STRLEN len;
1276 if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1))
1277 croak("Wide character in %s", "Socket::pack_ip_mreq");
1278 multiaddrbytes = SvPVbyte(multiaddr, len);
1279 if (len != sizeof(mreq.imr_multiaddr))
1280 croak("Bad arg length %s, length is %" UVuf ", should be %" UVuf,
1281 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_multiaddr));
1282 Zero(&mreq, sizeof(mreq), char);
1283 Copy(multiaddrbytes, &mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr), char);
1284 if(SvOK(interface)) {
1285 if (DO_UTF8(interface) && !sv_utf8_downgrade(interface, 1))
1286 croak("Wide character in %s", "Socket::pack_ip_mreq");
1287 interfacebytes = SvPVbyte(interface, len);
1288 if (len != sizeof(mreq.imr_interface))
1289 croak("Bad arg length %s, length is %" UVuf ", should be %" UVuf,
1290 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_interface));
1291 Copy(interfacebytes, &mreq.imr_interface, sizeof(mreq.imr_interface), char);
1292 }
1293 else
1294 mreq.imr_interface.s_addr = INADDR_ANY;
1295 ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq)));
1296 #else
1297 not_here("pack_ip_mreq");
1298 #endif
1299 }
1300
1301 void
unpack_ip_mreq(mreq_sv)1302 unpack_ip_mreq(mreq_sv)
1303 SV * mreq_sv
1304 PPCODE:
1305 {
1306 #ifdef HAS_IP_MREQ
1307 struct ip_mreq mreq;
1308 STRLEN mreqlen;
1309 char * mreqbytes = SvPVbyte(mreq_sv, mreqlen);
1310 if (mreqlen != sizeof(mreq))
1311 croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf,
1312 "Socket::unpack_ip_mreq", (UV)mreqlen, (UV)sizeof(mreq));
1313 Copy(mreqbytes, &mreq, sizeof(mreq), char);
1314 EXTEND(SP, 2);
1315 mPUSHp((char *)&mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr));
1316 mPUSHp((char *)&mreq.imr_interface, sizeof(mreq.imr_interface));
1317 #else
1318 not_here("unpack_ip_mreq");
1319 #endif
1320 }
1321
1322 void
1323 pack_ip_mreq_source(multiaddr, source, interface=&PL_sv_undef)
1324 SV * multiaddr
1325 SV * source
1326 SV * interface
1327 CODE:
1328 {
1329 #if defined(HAS_IP_MREQ_SOURCE) && defined (IP_ADD_SOURCE_MEMBERSHIP)
1330 struct ip_mreq_source mreq;
1331 char * multiaddrbytes;
1332 char * sourcebytes;
1333 char * interfacebytes;
1334 STRLEN len;
1335 if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1))
1336 croak("Wide character in %s", "Socket::pack_ip_mreq_source");
1337 multiaddrbytes = SvPVbyte(multiaddr, len);
1338 if (len != sizeof(mreq.imr_multiaddr))
1339 croak("Bad arg length %s, length is %" UVuf ", should be %" UVuf,
1340 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_multiaddr));
1341 if (DO_UTF8(source) && !sv_utf8_downgrade(source, 1))
1342 croak("Wide character in %s", "Socket::pack_ip_mreq_source");
1343 if (len != sizeof(mreq.imr_sourceaddr))
1344 croak("Bad arg length %s, length is %" UVuf ", should be %" UVuf,
1345 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_sourceaddr));
1346 sourcebytes = SvPVbyte(source, len);
1347 Zero(&mreq, sizeof(mreq), char);
1348 Copy(multiaddrbytes, &mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr), char);
1349 Copy(sourcebytes, &mreq.imr_sourceaddr, sizeof(mreq.imr_sourceaddr), char);
1350 if(SvOK(interface)) {
1351 if (DO_UTF8(interface) && !sv_utf8_downgrade(interface, 1))
1352 croak("Wide character in %s", "Socket::pack_ip_mreq");
1353 interfacebytes = SvPVbyte(interface, len);
1354 if (len != sizeof(mreq.imr_interface))
1355 croak("Bad arg length %s, length is %" UVuf ", should be %" UVuf,
1356 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_interface));
1357 Copy(interfacebytes, &mreq.imr_interface, sizeof(mreq.imr_interface), char);
1358 }
1359 else
1360 mreq.imr_interface.s_addr = INADDR_ANY;
1361 ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq)));
1362 #else
1363 PERL_UNUSED_VAR(multiaddr);
1364 PERL_UNUSED_VAR(source);
1365 not_here("pack_ip_mreq_source");
1366 #endif
1367 }
1368
1369 void
unpack_ip_mreq_source(mreq_sv)1370 unpack_ip_mreq_source(mreq_sv)
1371 SV * mreq_sv
1372 PPCODE:
1373 {
1374 #if defined(HAS_IP_MREQ_SOURCE) && defined (IP_ADD_SOURCE_MEMBERSHIP)
1375 struct ip_mreq_source mreq;
1376 STRLEN mreqlen;
1377 char * mreqbytes = SvPVbyte(mreq_sv, mreqlen);
1378 if (mreqlen != sizeof(mreq))
1379 croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf,
1380 "Socket::unpack_ip_mreq_source", (UV)mreqlen, (UV)sizeof(mreq));
1381 Copy(mreqbytes, &mreq, sizeof(mreq), char);
1382 EXTEND(SP, 3);
1383 mPUSHp((char *)&mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr));
1384 mPUSHp((char *)&mreq.imr_sourceaddr, sizeof(mreq.imr_sourceaddr));
1385 mPUSHp((char *)&mreq.imr_interface, sizeof(mreq.imr_interface));
1386 #else
1387 PERL_UNUSED_VAR(mreq_sv);
1388 not_here("unpack_ip_mreq_source");
1389 #endif
1390 }
1391
1392 void
pack_ipv6_mreq(multiaddr,ifindex)1393 pack_ipv6_mreq(multiaddr, ifindex)
1394 SV * multiaddr
1395 unsigned int ifindex
1396 CODE:
1397 {
1398 #ifdef HAS_IPV6_MREQ
1399 struct ipv6_mreq mreq;
1400 char * multiaddrbytes;
1401 STRLEN len;
1402 if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1))
1403 croak("Wide character in %s", "Socket::pack_ipv6_mreq");
1404 multiaddrbytes = SvPVbyte(multiaddr, len);
1405 if (len != sizeof(mreq.ipv6mr_multiaddr))
1406 croak("Bad arg length %s, length is %" UVuf ", should be %" UVuf,
1407 "Socket::pack_ipv6_mreq", (UV)len, (UV)sizeof(mreq.ipv6mr_multiaddr));
1408 Zero(&mreq, sizeof(mreq), char);
1409 Copy(multiaddrbytes, &mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr), char);
1410 mreq.ipv6mr_interface = ifindex;
1411 ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq)));
1412 #else
1413 PERL_UNUSED_VAR(multiaddr);
1414 PERL_UNUSED_VAR(ifindex);
1415 not_here("pack_ipv6_mreq");
1416 #endif
1417 }
1418
1419 void
unpack_ipv6_mreq(mreq_sv)1420 unpack_ipv6_mreq(mreq_sv)
1421 SV * mreq_sv
1422 PPCODE:
1423 {
1424 #ifdef HAS_IPV6_MREQ
1425 struct ipv6_mreq mreq;
1426 STRLEN mreqlen;
1427 char * mreqbytes = SvPVbyte(mreq_sv, mreqlen);
1428 if (mreqlen != sizeof(mreq))
1429 croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf,
1430 "Socket::unpack_ipv6_mreq", (UV)mreqlen, (UV)sizeof(mreq));
1431 Copy(mreqbytes, &mreq, sizeof(mreq), char);
1432 EXTEND(SP, 2);
1433 mPUSHp((char *)&mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr));
1434 mPUSHi(mreq.ipv6mr_interface);
1435 #else
1436 PERL_UNUSED_VAR(mreq_sv);
1437 not_here("unpack_ipv6_mreq");
1438 #endif
1439 }
1440