cpan/Socket/Socket.xs

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