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