cpan/Socket/Socket.xs

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