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