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