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