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(SvPV_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 340 static int 341 not_here(const char *s) 342 { 343 croak("Socket::%s not implemented on this architecture", s); 344 return -1; 345 } 346 347 #define PERL_IN_ADDR_S_ADDR_SIZE 4 348 349 /* 350 * Bad assumptions possible here. 351 * 352 * Bad Assumption 1: struct in_addr has no other fields 353 * than the s_addr (which is the field we care about 354 * in here, really). However, we can be fed either 4-byte 355 * addresses (from pack("N", ...), or va.b.c.d, or ...), 356 * or full struct in_addrs (from e.g. pack_sockaddr_in()), 357 * which may or may not be 4 bytes in size. 358 * 359 * Bad Assumption 2: the s_addr field is a simple type 360 * (such as an int, u_int32_t). It can be a bit field, 361 * in which case using & (address-of) on it or taking sizeof() 362 * wouldn't go over too well. (Those are not attempted 363 * now but in case someone thinks to change the below code 364 * to use addr.s_addr instead of addr, you have been warned.) 365 * 366 * Bad Assumption 3: the s_addr is the first field in 367 * an in_addr, or that its bytes are the first bytes in 368 * an in_addr. 369 * 370 * These bad assumptions are wrong in UNICOS which has 371 * struct in_addr { struct { u_long st_addr:32; } s_da }; 372 * #define s_addr s_da.st_addr 373 * and u_long is 64 bits. 374 * 375 * --jhi */ 376 377 #include "const-c.inc" 378 379 #ifdef HAS_GETADDRINFO 380 static SV *err_to_SV(pTHX_ int err) 381 { 382 SV *ret = sv_newmortal(); 383 (void) SvUPGRADE(ret, SVt_PVNV); 384 385 if(err) { 386 const char *error = gai_strerror(err); 387 sv_setpv(ret, error); 388 } 389 else { 390 sv_setpv(ret, ""); 391 } 392 393 SvIV_set(ret, err); SvIOK_on(ret); 394 395 return ret; 396 } 397 398 static void xs_getaddrinfo(pTHX_ CV *cv) 399 { 400 dXSARGS; 401 402 SV *host; 403 SV *service; 404 SV *hints; 405 406 char *hostname = NULL; 407 char *servicename = NULL; 408 STRLEN len; 409 struct addrinfo hints_s; 410 struct addrinfo *res; 411 struct addrinfo *res_iter; 412 int err; 413 int n_res; 414 415 PERL_UNUSED_ARG(cv); 416 if(items > 3) 417 croak("Usage: Socket::getaddrinfo(host, service, hints)"); 418 419 SP -= items; 420 421 if(items < 1) 422 host = &PL_sv_undef; 423 else 424 host = ST(0); 425 426 if(items < 2) 427 service = &PL_sv_undef; 428 else 429 service = ST(1); 430 431 if(items < 3) 432 hints = NULL; 433 else 434 hints = ST(2); 435 436 SvGETMAGIC(host); 437 if(SvOK(host)) { 438 hostname = SvPV_nomg(host, len); 439 if (!len) 440 hostname = NULL; 441 } 442 443 SvGETMAGIC(service); 444 if(SvOK(service)) { 445 servicename = SvPV_nomg(service, len); 446 if (!len) 447 servicename = NULL; 448 } 449 450 Zero(&hints_s, sizeof(hints_s), char); 451 hints_s.ai_family = PF_UNSPEC; 452 453 if(hints && SvOK(hints)) { 454 HV *hintshash; 455 SV **valp; 456 457 if(!SvROK(hints) || SvTYPE(SvRV(hints)) != SVt_PVHV) 458 croak("hints is not a HASH reference"); 459 460 hintshash = (HV*)SvRV(hints); 461 462 if((valp = hv_fetch(hintshash, "flags", 5, 0)) != NULL && SvOK(*valp)) 463 hints_s.ai_flags = SvIV(*valp); 464 if((valp = hv_fetch(hintshash, "family", 6, 0)) != NULL && SvOK(*valp)) 465 hints_s.ai_family = SvIV(*valp); 466 if((valp = hv_fetch(hintshash, "socktype", 8, 0)) != NULL && SvOK(*valp)) 467 hints_s.ai_socktype = SvIV(*valp); 468 if((valp = hv_fetch(hintshash, "protocol", 8, 0)) != NULL && SvOK(*valp)) 469 hints_s.ai_protocol = SvIV(*valp); 470 } 471 472 err = getaddrinfo(hostname, servicename, &hints_s, &res); 473 474 XPUSHs(err_to_SV(aTHX_ err)); 475 476 if(err) 477 XSRETURN(1); 478 479 n_res = 0; 480 for(res_iter = res; res_iter; res_iter = res_iter->ai_next) { 481 HV *res_hv = newHV(); 482 483 (void)hv_stores(res_hv, "family", newSViv(res_iter->ai_family)); 484 (void)hv_stores(res_hv, "socktype", newSViv(res_iter->ai_socktype)); 485 (void)hv_stores(res_hv, "protocol", newSViv(res_iter->ai_protocol)); 486 487 (void)hv_stores(res_hv, "addr", newSVpvn((char*)res_iter->ai_addr, res_iter->ai_addrlen)); 488 489 if(res_iter->ai_canonname) 490 (void)hv_stores(res_hv, "canonname", newSVpv(res_iter->ai_canonname, 0)); 491 else 492 (void)hv_stores(res_hv, "canonname", newSV(0)); 493 494 XPUSHs(sv_2mortal(newRV_noinc((SV*)res_hv))); 495 n_res++; 496 } 497 498 freeaddrinfo(res); 499 500 XSRETURN(1 + n_res); 501 } 502 #endif 503 504 #ifdef HAS_GETNAMEINFO 505 static void xs_getnameinfo(pTHX_ CV *cv) 506 { 507 dXSARGS; 508 509 SV *addr; 510 int flags; 511 int xflags; 512 513 char host[1024]; 514 char serv[256]; 515 char *sa; /* we'll cast to struct sockaddr * when necessary */ 516 STRLEN addr_len; 517 int err; 518 519 int want_host, want_serv; 520 521 PERL_UNUSED_ARG(cv); 522 if(items < 1 || items > 3) 523 croak("Usage: Socket::getnameinfo(addr, flags=0, xflags=0)"); 524 525 SP -= items; 526 527 addr = ST(0); 528 529 if(items < 2) 530 flags = 0; 531 else 532 flags = SvIV(ST(1)); 533 534 if(items < 3) 535 xflags = 0; 536 else 537 xflags = SvIV(ST(2)); 538 539 want_host = !(xflags & NIx_NOHOST); 540 want_serv = !(xflags & NIx_NOSERV); 541 542 if(!SvPOK(addr)) 543 croak("addr is not a string"); 544 545 addr_len = SvCUR(addr); 546 547 /* We need to ensure the sockaddr is aligned, because a random SvPV might 548 * not be due to SvOOK */ 549 Newx(sa, addr_len, char); 550 Copy(SvPV_nolen(addr), sa, addr_len, char); 551 #ifdef HAS_SOCKADDR_SA_LEN 552 ((struct sockaddr *)sa)->sa_len = addr_len; 553 #endif 554 555 err = getnameinfo((struct sockaddr *)sa, addr_len, 556 want_host ? host : NULL, want_host ? sizeof(host) : 0, 557 want_serv ? serv : NULL, want_serv ? sizeof(serv) : 0, 558 flags); 559 560 Safefree(sa); 561 562 XPUSHs(err_to_SV(aTHX_ err)); 563 564 if(err) 565 XSRETURN(1); 566 567 XPUSHs(want_host ? sv_2mortal(newSVpv(host, 0)) : &PL_sv_undef); 568 XPUSHs(want_serv ? sv_2mortal(newSVpv(serv, 0)) : &PL_sv_undef); 569 570 XSRETURN(3); 571 } 572 #endif 573 574 MODULE = Socket PACKAGE = Socket 575 576 INCLUDE: const-xs.inc 577 578 BOOT: 579 #ifdef HAS_GETADDRINFO 580 newXS("Socket::getaddrinfo", xs_getaddrinfo, __FILE__); 581 #endif 582 #ifdef HAS_GETNAMEINFO 583 newXS("Socket::getnameinfo", xs_getnameinfo, __FILE__); 584 #endif 585 586 void 587 inet_aton(host) 588 char * host 589 CODE: 590 { 591 struct in_addr ip_address; 592 struct hostent * phe; 593 594 if ((*host != '\0') && inet_aton(host, &ip_address)) { 595 ST(0) = sv_2mortal(newSVpvn((char *)&ip_address, sizeof(ip_address))); 596 XSRETURN(1); 597 } 598 599 phe = gethostbyname(host); 600 if (phe && phe->h_addrtype == AF_INET && phe->h_length == 4) { 601 ST(0) = sv_2mortal(newSVpvn((char *)phe->h_addr, phe->h_length)); 602 XSRETURN(1); 603 } 604 605 XSRETURN_UNDEF; 606 } 607 608 void 609 inet_ntoa(ip_address_sv) 610 SV * ip_address_sv 611 CODE: 612 { 613 STRLEN addrlen; 614 struct in_addr addr; 615 char * ip_address; 616 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) 617 croak("Wide character in %s", "Socket::inet_ntoa"); 618 ip_address = SvPVbyte(ip_address_sv, addrlen); 619 if (addrlen == sizeof(addr) || addrlen == 4) 620 addr.s_addr = 621 (ip_address[0] & 0xFF) << 24 | 622 (ip_address[1] & 0xFF) << 16 | 623 (ip_address[2] & 0xFF) << 8 | 624 (ip_address[3] & 0xFF); 625 else 626 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 627 "Socket::inet_ntoa", (UV)addrlen, (UV)sizeof(addr)); 628 /* We could use inet_ntoa() but that is broken 629 * in HP-UX + GCC + 64bitint (returns "0.0.0.0"), 630 * so let's use this sprintf() workaround everywhere. 631 * This is also more threadsafe than using inet_ntoa(). */ 632 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "%d.%d.%d.%d", /* IPv6? */ 633 ((addr.s_addr >> 24) & 0xFF), 634 ((addr.s_addr >> 16) & 0xFF), 635 ((addr.s_addr >> 8) & 0xFF), 636 ( addr.s_addr & 0xFF))); 637 } 638 639 void 640 sockaddr_family(sockaddr) 641 SV * sockaddr 642 PREINIT: 643 STRLEN sockaddr_len; 644 char *sockaddr_pv = SvPVbyte(sockaddr, sockaddr_len); 645 CODE: 646 if (sockaddr_len < offsetof(struct sockaddr, sa_data)) 647 croak("Bad arg length for %s, length is %"UVuf", should be at least %"UVuf, 648 "Socket::sockaddr_family", (UV)sockaddr_len, 649 (UV)offsetof(struct sockaddr, sa_data)); 650 ST(0) = sv_2mortal(newSViv(((struct sockaddr*)sockaddr_pv)->sa_family)); 651 652 void 653 pack_sockaddr_un(pathname) 654 SV * pathname 655 CODE: 656 { 657 #ifdef I_SYS_UN 658 struct sockaddr_un sun_ad; /* fear using sun */ 659 STRLEN len; 660 char * pathname_pv; 661 int addr_len; 662 663 Zero(&sun_ad, sizeof(sun_ad), char); 664 sun_ad.sun_family = AF_UNIX; 665 pathname_pv = SvPV(pathname,len); 666 if (len > sizeof(sun_ad.sun_path)) 667 len = sizeof(sun_ad.sun_path); 668 # ifdef OS2 /* Name should start with \socket\ and contain backslashes! */ 669 { 670 int off; 671 char *s, *e; 672 673 if (pathname_pv[0] != '/' && pathname_pv[0] != '\\') 674 croak("Relative UNIX domain socket name '%s' unsupported", 675 pathname_pv); 676 else if (len < 8 677 || pathname_pv[7] != '/' && pathname_pv[7] != '\\' 678 || !strnicmp(pathname_pv + 1, "socket", 6)) 679 off = 7; 680 else 681 off = 0; /* Preserve names starting with \socket\ */ 682 Copy("\\socket", sun_ad.sun_path, off, char); 683 Copy(pathname_pv, sun_ad.sun_path + off, len, char); 684 685 s = sun_ad.sun_path + off - 1; 686 e = s + len + 1; 687 while (++s < e) 688 if (*s = '/') 689 *s = '\\'; 690 } 691 # else /* !( defined OS2 ) */ 692 Copy(pathname_pv, sun_ad.sun_path, len, char); 693 # endif 694 if (0) not_here("dummy"); 695 if (len > 1 && sun_ad.sun_path[0] == '\0') { 696 /* Linux-style abstract-namespace socket. 697 * The name is not a file name, but an array of arbitrary 698 * character, starting with \0 and possibly including \0s, 699 * therefore the length of the structure must denote the 700 * end of that character array */ 701 addr_len = (char *)&(sun_ad.sun_path) - (char *)&sun_ad + len; 702 } else { 703 addr_len = sizeof(sun_ad); 704 } 705 # ifdef HAS_SOCKADDR_SA_LEN 706 sun_ad.sun_len = addr_len; 707 # endif 708 ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, addr_len)); 709 #else 710 ST(0) = (SV*)not_here("pack_sockaddr_un"); 711 #endif 712 713 } 714 715 void 716 unpack_sockaddr_un(sun_sv) 717 SV * sun_sv 718 CODE: 719 { 720 #ifdef I_SYS_UN 721 struct sockaddr_un addr; 722 STRLEN sockaddrlen; 723 char * sun_ad = SvPVbyte(sun_sv,sockaddrlen); 724 int addr_len; 725 # if defined(__linux__) || defined(HAS_SOCKADDR_SA_LEN) 726 /* On Linux or *BSD sockaddrlen on sockets returned by accept, recvfrom, 727 getpeername and getsockname is not equal to sizeof(addr). */ 728 if (sockaddrlen < sizeof(addr)) { 729 Copy(sun_ad, &addr, sockaddrlen, char); 730 Zero(((char*)&addr) + sockaddrlen, sizeof(addr) - sockaddrlen, char); 731 } else { 732 Copy(sun_ad, &addr, sizeof(addr), char); 733 } 734 # ifdef HAS_SOCKADDR_SA_LEN 735 /* In this case, sun_len must be checked */ 736 if (sockaddrlen != addr.sun_len) 737 croak("Invalid arg sun_len field for %s, length is %"UVuf", but sun_len is %"UVuf, 738 "Socket::unpack_sockaddr_un", (UV)sockaddrlen, (UV)addr.sun_len); 739 # endif 740 # else 741 if (sockaddrlen != sizeof(addr)) 742 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 743 "Socket::unpack_sockaddr_un", (UV)sockaddrlen, (UV)sizeof(addr)); 744 Copy(sun_ad, &addr, sizeof(addr), char); 745 # endif 746 747 if (addr.sun_family != AF_UNIX) 748 croak("Bad address family for %s, got %d, should be %d", 749 "Socket::unpack_sockaddr_un", addr.sun_family, AF_UNIX); 750 # ifdef __linux__ 751 if (addr.sun_path[0] == '\0') { 752 /* Linux-style abstract socket address begins with a nul 753 * and can contain nuls. */ 754 addr_len = (char *)&addr - (char *)&(addr.sun_path) + sockaddrlen; 755 } else 756 # endif 757 { 758 # if defined(HAS_SOCKADDR_SA_LEN) 759 /* On *BSD sun_path not always ends with a '\0' */ 760 int maxlen = addr.sun_len - 2; /* should use offsetof(struct sockaddr_un, sun_path) instead of 2 */ 761 if (maxlen > (int)sizeof(addr.sun_path)) 762 maxlen = (int)sizeof(addr.sun_path); 763 # else 764 const int maxlen = (int)sizeof(addr.sun_path); 765 # endif 766 for (addr_len = 0; addr.sun_path[addr_len] 767 && addr_len < maxlen; addr_len++); 768 } 769 770 ST(0) = sv_2mortal(newSVpvn(addr.sun_path, addr_len)); 771 #else 772 ST(0) = (SV*)not_here("unpack_sockaddr_un"); 773 #endif 774 } 775 776 void 777 pack_sockaddr_in(port, ip_address_sv) 778 unsigned short port 779 SV * ip_address_sv 780 CODE: 781 { 782 struct sockaddr_in sin; 783 struct in_addr addr; 784 STRLEN addrlen; 785 char * ip_address; 786 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) 787 croak("Wide character in %s", "Socket::pack_sockaddr_in"); 788 ip_address = SvPVbyte(ip_address_sv, addrlen); 789 if (addrlen == sizeof(addr) || addrlen == 4) 790 addr.s_addr = 791 (ip_address[0] & 0xFF) << 24 | 792 (ip_address[1] & 0xFF) << 16 | 793 (ip_address[2] & 0xFF) << 8 | 794 (ip_address[3] & 0xFF); 795 else 796 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 797 "Socket::pack_sockaddr_in", 798 (UV)addrlen, (UV)sizeof(addr)); 799 Zero(&sin, sizeof(sin), char); 800 sin.sin_family = AF_INET; 801 sin.sin_port = htons(port); 802 sin.sin_addr.s_addr = htonl(addr.s_addr); 803 # ifdef HAS_SOCKADDR_SA_LEN 804 sin.sin_len = sizeof(sin); 805 # endif 806 ST(0) = sv_2mortal(newSVpvn((char *)&sin, sizeof(sin))); 807 } 808 809 void 810 unpack_sockaddr_in(sin_sv) 811 SV * sin_sv 812 PPCODE: 813 { 814 STRLEN sockaddrlen; 815 struct sockaddr_in addr; 816 SV *ip_address_sv; 817 char * sin = SvPVbyte(sin_sv,sockaddrlen); 818 if (sockaddrlen != sizeof(addr)) { 819 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 820 "Socket::unpack_sockaddr_in", sockaddrlen, sizeof(addr)); 821 } 822 Copy(sin, &addr, sizeof(addr), char); 823 if (addr.sin_family != AF_INET) { 824 croak("Bad address family for %s, got %d, should be %d", 825 "Socket::unpack_sockaddr_in", addr.sin_family, AF_INET); 826 } 827 ip_address_sv = newSVpvn((char *)&addr.sin_addr, sizeof(addr.sin_addr)); 828 829 if(GIMME_V == G_ARRAY) { 830 EXTEND(SP, 2); 831 mPUSHi(ntohs(addr.sin_port)); 832 mPUSHs(ip_address_sv); 833 } 834 else { 835 mPUSHs(ip_address_sv); 836 } 837 } 838 839 void 840 pack_sockaddr_in6(port, sin6_addr, scope_id=0, flowinfo=0) 841 unsigned short port 842 SV * sin6_addr 843 unsigned long scope_id 844 unsigned long flowinfo 845 CODE: 846 { 847 #ifdef HAS_SOCKADDR_IN6 848 struct sockaddr_in6 sin6; 849 char * addrbytes; 850 STRLEN addrlen; 851 if (DO_UTF8(sin6_addr) && !sv_utf8_downgrade(sin6_addr, 1)) 852 croak("Wide character in %s", "Socket::pack_sockaddr_in6"); 853 addrbytes = SvPVbyte(sin6_addr, addrlen); 854 if (addrlen != sizeof(sin6.sin6_addr)) 855 croak("Bad arg length %s, length is %"UVuf", should be %"UVuf, 856 "Socket::pack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6.sin6_addr)); 857 Zero(&sin6, sizeof(sin6), char); 858 sin6.sin6_family = AF_INET6; 859 sin6.sin6_port = htons(port); 860 sin6.sin6_flowinfo = htonl(flowinfo); 861 Copy(addrbytes, &sin6.sin6_addr, sizeof(sin6.sin6_addr), char); 862 # ifdef HAS_SIN6_SCOPE_ID 863 sin6.sin6_scope_id = scope_id; 864 # else 865 if (scope_id != 0) 866 warn("%s cannot represent non-zero scope_id %d", 867 "Socket::pack_sockaddr_in6", scope_id); 868 # endif 869 # ifdef HAS_SOCKADDR_SA_LEN 870 sin6.sin6_len = sizeof(sin6); 871 # endif 872 ST(0) = sv_2mortal(newSVpvn((char *)&sin6, sizeof(sin6))); 873 #else 874 ST(0) = (SV*)not_here("pack_sockaddr_in6"); 875 #endif 876 } 877 878 void 879 unpack_sockaddr_in6(sin6_sv) 880 SV * sin6_sv 881 PPCODE: 882 { 883 #ifdef HAS_SOCKADDR_IN6 884 STRLEN addrlen; 885 struct sockaddr_in6 sin6; 886 char * addrbytes = SvPVbyte(sin6_sv, addrlen); 887 SV *ip_address_sv; 888 if (addrlen != sizeof(sin6)) 889 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 890 "Socket::unpack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6)); 891 Copy(addrbytes, &sin6, sizeof(sin6), char); 892 if (sin6.sin6_family != AF_INET6) 893 croak("Bad address family for %s, got %d, should be %d", 894 "Socket::unpack_sockaddr_in6", sin6.sin6_family, AF_INET6); 895 ip_address_sv = newSVpvn((char *)&sin6.sin6_addr, sizeof(sin6.sin6_addr)); 896 897 if(GIMME_V == G_ARRAY) { 898 EXTEND(SP, 4); 899 mPUSHi(ntohs(sin6.sin6_port)); 900 mPUSHs(ip_address_sv); 901 # ifdef HAS_SIN6_SCOPE_ID 902 mPUSHi(sin6.sin6_scope_id); 903 # else 904 mPUSHi(0); 905 # endif 906 mPUSHi(ntohl(sin6.sin6_flowinfo)); 907 } 908 else { 909 mPUSHs(ip_address_sv); 910 } 911 #else 912 ST(0) = (SV*)not_here("pack_sockaddr_in6"); 913 #endif 914 } 915 916 void 917 inet_ntop(af, ip_address_sv) 918 int af 919 SV * ip_address_sv 920 CODE: 921 #ifdef HAS_INETNTOP 922 STRLEN addrlen; 923 #ifdef AF_INET6 924 struct in6_addr addr; 925 char str[INET6_ADDRSTRLEN]; 926 #else 927 struct in_addr addr; 928 char str[INET_ADDRSTRLEN]; 929 #endif 930 char *ip_address; 931 932 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) 933 croak("Wide character in %s", "Socket::inet_ntop"); 934 935 ip_address = SvPV(ip_address_sv, addrlen); 936 937 switch(af) { 938 case AF_INET: 939 if(addrlen != 4) 940 croak("Bad address length for Socket::inet_ntop on AF_INET;" 941 " got %"UVuf", should be 4", (UV)addrlen); 942 break; 943 #ifdef AF_INET6 944 case AF_INET6: 945 if(addrlen != 16) 946 croak("Bad address length for Socket::inet_ntop on AF_INET6;" 947 " got %"UVuf", should be 16", (UV)addrlen); 948 break; 949 #endif 950 default: 951 croak("Bad address family for %s, got %d, should be" 952 #ifdef AF_INET6 953 " either AF_INET or AF_INET6", 954 #else 955 " AF_INET", 956 #endif 957 "Socket::inet_ntop", af); 958 } 959 960 if(addrlen < sizeof(addr)) { 961 Copy(ip_address, &addr, addrlen, char); 962 Zero(((char*)&addr) + addrlen, sizeof(addr) - addrlen, char); 963 } 964 else { 965 Copy(ip_address, &addr, sizeof addr, char); 966 } 967 inet_ntop(af, &addr, str, sizeof str); 968 969 ST(0) = sv_2mortal(newSVpvn(str, strlen(str))); 970 #else 971 ST(0) = (SV*)not_here("inet_ntop"); 972 #endif 973 974 void 975 inet_pton(af, host) 976 int af 977 const char * host 978 CODE: 979 #ifdef HAS_INETPTON 980 int ok; 981 int addrlen = 0; 982 #ifdef AF_INET6 983 struct in6_addr ip_address; 984 #else 985 struct in_addr ip_address; 986 #endif 987 988 switch(af) { 989 case AF_INET: 990 addrlen = 4; 991 break; 992 #ifdef AF_INET6 993 case AF_INET6: 994 addrlen = 16; 995 break; 996 #endif 997 default: 998 croak("Bad address family for %s, got %d, should be" 999 #ifdef AF_INET6 1000 " either AF_INET or AF_INET6", 1001 #else 1002 " AF_INET", 1003 #endif 1004 "Socket::inet_pton", af); 1005 } 1006 ok = (*host != '\0') && inet_pton(af, host, &ip_address); 1007 1008 ST(0) = sv_newmortal(); 1009 if (ok) { 1010 sv_setpvn( ST(0), (char *)&ip_address, addrlen); 1011 } 1012 #else 1013 ST(0) = (SV*)not_here("inet_pton"); 1014 #endif 1015 1016 void 1017 pack_ip_mreq(multiaddr, interface=&PL_sv_undef) 1018 SV * multiaddr 1019 SV * interface 1020 CODE: 1021 { 1022 #ifdef HAS_IP_MREQ 1023 struct ip_mreq mreq; 1024 char * multiaddrbytes; 1025 char * interfacebytes; 1026 STRLEN len; 1027 if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1)) 1028 croak("Wide character in %s", "Socket::pack_ip_mreq"); 1029 multiaddrbytes = SvPVbyte(multiaddr, len); 1030 if (len != sizeof(mreq.imr_multiaddr)) 1031 croak("Bad arg length %s, length is %"UVuf", should be %"UVuf, 1032 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_multiaddr)); 1033 Zero(&mreq, sizeof(mreq), char); 1034 Copy(multiaddrbytes, &mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr), char); 1035 if(SvOK(interface)) { 1036 if (DO_UTF8(interface) && !sv_utf8_downgrade(interface, 1)) 1037 croak("Wide character in %s", "Socket::pack_ip_mreq"); 1038 interfacebytes = SvPVbyte(interface, len); 1039 if (len != sizeof(mreq.imr_interface)) 1040 croak("Bad arg length %s, length is %"UVuf", should be %"UVuf, 1041 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_interface)); 1042 Copy(interfacebytes, &mreq.imr_interface, sizeof(mreq.imr_interface), char); 1043 } 1044 else 1045 mreq.imr_interface.s_addr = INADDR_ANY; 1046 ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq))); 1047 #else 1048 not_here("pack_ip_mreq"); 1049 #endif 1050 } 1051 1052 void 1053 unpack_ip_mreq(mreq_sv) 1054 SV * mreq_sv 1055 PPCODE: 1056 { 1057 #ifdef HAS_IP_MREQ 1058 struct ip_mreq mreq; 1059 STRLEN mreqlen; 1060 char * mreqbytes = SvPVbyte(mreq_sv, mreqlen); 1061 if (mreqlen != sizeof(mreq)) 1062 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 1063 "Socket::unpack_ip_mreq", (UV)mreqlen, (UV)sizeof(mreq)); 1064 Copy(mreqbytes, &mreq, sizeof(mreq), char); 1065 EXTEND(SP, 2); 1066 mPUSHp((char *)&mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr)); 1067 mPUSHp((char *)&mreq.imr_interface, sizeof(mreq.imr_interface)); 1068 #else 1069 not_here("unpack_ip_mreq"); 1070 #endif 1071 } 1072 1073 void 1074 pack_ip_mreq_source(multiaddr, source, interface=&PL_sv_undef) 1075 SV * multiaddr 1076 SV * source 1077 SV * interface 1078 CODE: 1079 { 1080 #if defined(HAS_IP_MREQ_SOURCE) && defined (IP_ADD_SOURCE_MEMBERSHIP) 1081 struct ip_mreq_source mreq; 1082 char * multiaddrbytes; 1083 char * sourcebytes; 1084 char * interfacebytes; 1085 STRLEN len; 1086 if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1)) 1087 croak("Wide character in %s", "Socket::pack_ip_mreq_source"); 1088 multiaddrbytes = SvPVbyte(multiaddr, len); 1089 if (len != sizeof(mreq.imr_multiaddr)) 1090 croak("Bad arg length %s, length is %"UVuf", should be %"UVuf, 1091 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_multiaddr)); 1092 if (DO_UTF8(source) && !sv_utf8_downgrade(source, 1)) 1093 croak("Wide character in %s", "Socket::pack_ip_mreq_source"); 1094 if (len != sizeof(mreq.imr_sourceaddr)) 1095 croak("Bad arg length %s, length is %"UVuf", should be %"UVuf, 1096 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_sourceaddr)); 1097 sourcebytes = SvPVbyte(source, len); 1098 Zero(&mreq, sizeof(mreq), char); 1099 Copy(multiaddrbytes, &mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr), char); 1100 Copy(sourcebytes, &mreq.imr_sourceaddr, sizeof(mreq.imr_sourceaddr), char); 1101 if(SvOK(interface)) { 1102 if (DO_UTF8(interface) && !sv_utf8_downgrade(interface, 1)) 1103 croak("Wide character in %s", "Socket::pack_ip_mreq"); 1104 interfacebytes = SvPVbyte(interface, len); 1105 if (len != sizeof(mreq.imr_interface)) 1106 croak("Bad arg length %s, length is %"UVuf", should be %"UVuf, 1107 "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_interface)); 1108 Copy(interfacebytes, &mreq.imr_interface, sizeof(mreq.imr_interface), char); 1109 } 1110 else 1111 mreq.imr_interface.s_addr = INADDR_ANY; 1112 ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq))); 1113 #else 1114 not_here("pack_ip_mreq_source"); 1115 #endif 1116 } 1117 1118 void 1119 unpack_ip_mreq_source(mreq_sv) 1120 SV * mreq_sv 1121 PPCODE: 1122 { 1123 #if defined(HAS_IP_MREQ_SOURCE) && defined (IP_ADD_SOURCE_MEMBERSHIP) 1124 struct ip_mreq_source mreq; 1125 STRLEN mreqlen; 1126 char * mreqbytes = SvPVbyte(mreq_sv, mreqlen); 1127 if (mreqlen != sizeof(mreq)) 1128 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 1129 "Socket::unpack_ip_mreq_source", (UV)mreqlen, (UV)sizeof(mreq)); 1130 Copy(mreqbytes, &mreq, sizeof(mreq), char); 1131 EXTEND(SP, 3); 1132 mPUSHp((char *)&mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr)); 1133 mPUSHp((char *)&mreq.imr_sourceaddr, sizeof(mreq.imr_sourceaddr)); 1134 mPUSHp((char *)&mreq.imr_interface, sizeof(mreq.imr_interface)); 1135 #else 1136 not_here("unpack_ip_mreq_source"); 1137 #endif 1138 } 1139 1140 void 1141 pack_ipv6_mreq(multiaddr, ifindex) 1142 SV * multiaddr 1143 unsigned int ifindex 1144 CODE: 1145 { 1146 #ifdef HAS_IPV6_MREQ 1147 struct ipv6_mreq mreq; 1148 char * multiaddrbytes; 1149 STRLEN len; 1150 if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1)) 1151 croak("Wide character in %s", "Socket::pack_ipv6_mreq"); 1152 multiaddrbytes = SvPVbyte(multiaddr, len); 1153 if (len != sizeof(mreq.ipv6mr_multiaddr)) 1154 croak("Bad arg length %s, length is %"UVuf", should be %"UVuf, 1155 "Socket::pack_ipv6_mreq", (UV)len, (UV)sizeof(mreq.ipv6mr_multiaddr)); 1156 Zero(&mreq, sizeof(mreq), char); 1157 Copy(multiaddrbytes, &mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr), char); 1158 mreq.ipv6mr_interface = ifindex; 1159 ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq))); 1160 #else 1161 not_here("pack_ipv6_mreq"); 1162 #endif 1163 } 1164 1165 void 1166 unpack_ipv6_mreq(mreq_sv) 1167 SV * mreq_sv 1168 PPCODE: 1169 { 1170 #ifdef HAS_IPV6_MREQ 1171 struct ipv6_mreq mreq; 1172 STRLEN mreqlen; 1173 char * mreqbytes = SvPVbyte(mreq_sv, mreqlen); 1174 if (mreqlen != sizeof(mreq)) 1175 croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf, 1176 "Socket::unpack_ipv6_mreq", (UV)mreqlen, (UV)sizeof(mreq)); 1177 Copy(mreqbytes, &mreq, sizeof(mreq), char); 1178 EXTEND(SP, 2); 1179 mPUSHp((char *)&mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr)); 1180 mPUSHi(mreq.ipv6mr_interface); 1181 #else 1182 not_here("unpack_ipv6_mreq"); 1183 #endif 1184 } 1185