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