1 /* 2 * This file was generated automatically by ExtUtils::ParseXS version 2.10 from the 3 * contents of Socket.xs. Do not edit this file, edit Socket.xs instead. 4 * 5 * ANY CHANGES MADE HERE WILL BE LOST! 6 * 7 */ 8 9 #line 1 "Socket.xs" 10 #define PERL_NO_GET_CONTEXT 11 #include "EXTERN.h" 12 #include "perl.h" 13 #include "XSUB.h" 14 15 #include 16 17 #ifndef VMS 18 # ifdef I_SYS_TYPES 19 # include 20 # endif 21 # if !defined(ultrix) /* Avoid double definition. */ 22 # include 23 # endif 24 # if defined(USE_SOCKS) && defined(I_SOCKS) 25 # include 26 # endif 27 # ifdef MPE 28 # define PF_INET AF_INET 29 # define PF_UNIX AF_UNIX 30 # define SOCK_RAW 3 31 # endif 32 # ifdef I_SYS_UN 33 # include 34 # endif 35 /* XXX Configure test for 38 # endif 39 # if defined(__sgi) && !defined(AF_LINK) && defined(PF_LINK) && PF_LINK == AF_LNK 40 # undef PF_LINK 41 # endif 42 # if defined(I_NETINET_IN) || defined(__ultrix__) 43 # include 44 # endif 45 # ifdef I_NETDB 46 # if !defined(ultrix) /* Avoid double definition. */ 47 # include 48 # endif 49 # endif 50 # ifdef I_ARPA_INET 51 # include 52 # endif 53 # ifdef I_NETINET_TCP 54 # include 55 # endif 56 #else 57 # include "sockadapt.h" 58 #endif 59 60 #ifdef NETWARE 61 NETDB_DEFINE_CONTEXT 62 NETINET_DEFINE_CONTEXT 63 #endif 64 65 #ifdef I_SYSUIO 66 # include 67 #endif 68 69 #ifndef AF_NBS 70 # undef PF_NBS 71 #endif 72 73 #ifndef AF_X25 74 # undef PF_X25 75 #endif 76 77 #ifndef INADDR_NONE 78 # define INADDR_NONE 0xffffffff 79 #endif /* INADDR_NONE */ 80 #ifndef INADDR_BROADCAST 81 # define INADDR_BROADCAST 0xffffffff 82 #endif /* INADDR_BROADCAST */ 83 #ifndef INADDR_LOOPBACK 84 # define INADDR_LOOPBACK 0x7F000001 85 #endif /* INADDR_LOOPBACK */ 86 87 #ifndef HAS_INET_ATON 88 89 /* 90 * Check whether "cp" is a valid ascii representation 91 * of an Internet address and convert to a binary address. 92 * Returns 1 if the address is valid, 0 if not. 93 * This replaces inet_addr, the return value from which 94 * cannot distinguish between failure and a local broadcast address. 95 */ 96 static int 97 my_inet_aton(register const char *cp, struct in_addr *addr) 98 { 99 dTHX; 100 register U32 val; 101 register int base; 102 register char c; 103 int nparts; 104 const char *s; 105 unsigned int parts[4]; 106 register unsigned int *pp = parts; 107 108 if (!cp || !*cp) 109 return 0; 110 for (;;) { 111 /* 112 * Collect number up to ``.''. 113 * Values are specified as for C: 114 * 0x=hex, 0=octal, other=decimal. 115 */ 116 val = 0; base = 10; 117 if (*cp == '0') { 118 if (*++cp == 'x' || *cp == 'X') 119 base = 16, cp++; 120 else 121 base = 8; 122 } 123 while ((c = *cp) != '\0') { 124 if (isDIGIT(c)) { 125 val = (val * base) + (c - '0'); 126 cp++; 127 continue; 128 } 129 if (base == 16 && (s=strchr(PL_hexdigit,c))) { 130 val = (val << 4) + 131 ((s - PL_hexdigit) & 15); 132 cp++; 133 continue; 134 } 135 break; 136 } 137 if (*cp == '.') { 138 /* 139 * Internet format: 140 * a.b.c.d 141 * a.b.c (with c treated as 16-bits) 142 * a.b (with b treated as 24 bits) 143 */ 144 if (pp >= parts + 3 || val > 0xff) 145 return 0; 146 *pp++ = val, cp++; 147 } else 148 break; 149 } 150 /* 151 * Check for trailing characters. 152 */ 153 if (*cp && !isSPACE(*cp)) 154 return 0; 155 /* 156 * Concoct the address according to 157 * the number of parts specified. 158 */ 159 nparts = pp - parts + 1; /* force to an int for switch() */ 160 switch (nparts) { 161 162 case 1: /* a -- 32 bits */ 163 break; 164 165 case 2: /* a.b -- 8.24 bits */ 166 if (val > 0xffffff) 167 return 0; 168 val |= parts[0] << 24; 169 break; 170 171 case 3: /* a.b.c -- 8.8.16 bits */ 172 if (val > 0xffff) 173 return 0; 174 val |= (parts[0] << 24) | (parts[1] << 16); 175 break; 176 177 case 4: /* a.b.c.d -- 8.8.8.8 bits */ 178 if (val > 0xff) 179 return 0; 180 val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8); 181 break; 182 } 183 addr->s_addr = htonl(val); 184 return 1; 185 } 186 187 #undef inet_aton 188 #define inet_aton my_inet_aton 189 190 #endif /* ! HAS_INET_ATON */ 191 192 193 static int 194 not_here(char *s) 195 { 196 croak("Socket::%s not implemented on this architecture", s); 197 return -1; 198 } 199 200 #define PERL_IN_ADDR_S_ADDR_SIZE 4 201 202 /* 203 * Bad assumptions possible here. 204 * 205 * Bad Assumption 1: struct in_addr has no other fields 206 * than the s_addr (which is the field we care about 207 * in here, really). However, we can be fed either 4-byte 208 * addresses (from pack("N", ...), or va.b.c.d, or ...), 209 * or full struct in_addrs (from e.g. pack_sockaddr_in()), 210 * which may or may not be 4 bytes in size. 211 * 212 * Bad Assumption 2: the s_addr field is a simple type 213 * (such as an int, u_int32_t). It can be a bit field, 214 * in which case using & (address-of) on it or taking sizeof() 215 * wouldn't go over too well. (Those are not attempted 216 * now but in case someone thinks to change the below code 217 * to use addr.s_addr instead of addr, you have been warned.) 218 * 219 * Bad Assumption 3: the s_addr is the first field in 220 * an in_addr, or that its bytes are the first bytes in 221 * an in_addr. 222 * 223 * These bad assumptions are wrong in UNICOS which has 224 * struct in_addr { struct { u_long st_addr:32; } s_da }; 225 * #define s_addr s_da.st_addr 226 * and u_long is 64 bits. 227 * 228 * --jhi */ 229 230 #include "const-c.inc" 231 232 #ifndef PERL_UNUSED_VAR 233 # define PERL_UNUSED_VAR(var) if (0) var = var 234 #endif 235 236 #line 237 "Socket.c" 237 238 /* INCLUDE: Including 'const-xs.inc' from 'Socket.xs' */ 239 240 241 XS(XS_Socket_constant); /* prototype to pass -Wmissing-prototypes */ 242 XS(XS_Socket_constant) 243 115 { 244 115 dXSARGS; 245 115 if (items != 1) 246 ###### Perl_croak(aTHX_ "Usage: Socket::constant(sv)"); 247 115 PERL_UNUSED_VAR(cv); /* -W */ 248 115 PERL_UNUSED_VAR(ax); /* -Wall */ 249 115 SP -= items; 250 { 251 #line 4 "Socket.xs" 252 #ifdef dXSTARG 253 dXSTARG; /* Faster if we have it. */ 254 #else 255 dTARGET; 256 #endif 257 STRLEN len; 258 int type; 259 IV iv; 260 /* NV nv; Uncomment this if you need to return NVs */ 261 /* const char *pv; Uncomment this if you need to return PVs */ 262 #line 263 "Socket.c" 263 115 SV * sv = ST(0); 264 115 const char * s = SvPV(sv, len); 265 #line 18 "Socket.xs" 266 /* Change this to constant(aTHX_ s, len, &iv, &nv); 267 if you need to return both NVs and IVs */ 268 type = constant(aTHX_ s, len, &iv, &sv); 269 /* Return 1 or 2 items. First is error message, or undef if no error. 270 Second, if present, is found value */ 271 switch (type) { 272 case PERL_constant_NOTFOUND: 273 sv = sv_2mortal(newSVpvf("%s is not a valid Socket macro", s)); 274 PUSHs(sv); 275 break; 276 case PERL_constant_NOTDEF: 277 sv = sv_2mortal(newSVpvf( 278 "Your vendor has not defined Socket macro %s, used", s)); 279 PUSHs(sv); 280 break; 281 case PERL_constant_ISIV: 282 EXTEND(SP, 1); 283 PUSHs(&PL_sv_undef); 284 PUSHi(iv); 285 break; 286 /* Uncomment this if you need to return NOs 287 case PERL_constant_ISNO: 288 EXTEND(SP, 1); 289 PUSHs(&PL_sv_undef); 290 PUSHs(&PL_sv_no); 291 break; */ 292 /* Uncomment this if you need to return NVs 293 case PERL_constant_ISNV: 294 EXTEND(SP, 1); 295 PUSHs(&PL_sv_undef); 296 PUSHn(nv); 297 break; */ 298 /* Uncomment this if you need to return PVs 299 case PERL_constant_ISPV: 300 EXTEND(SP, 1); 301 PUSHs(&PL_sv_undef); 302 PUSHp(pv, strlen(pv)); 303 break; */ 304 /* Uncomment this if you need to return PVNs 305 case PERL_constant_ISPVN: 306 EXTEND(SP, 1); 307 PUSHs(&PL_sv_undef); 308 PUSHp(pv, iv); 309 break; */ 310 case PERL_constant_ISSV: 311 EXTEND(SP, 1); 312 PUSHs(&PL_sv_undef); 313 PUSHs(sv); 314 break; 315 /* Uncomment this if you need to return UNDEFs 316 case PERL_constant_ISUNDEF: 317 break; */ 318 /* Uncomment this if you need to return UVs 319 case PERL_constant_ISUV: 320 EXTEND(SP, 1); 321 PUSHs(&PL_sv_undef); 322 PUSHu((UV)iv); 323 break; */ 324 /* Uncomment this if you need to return YESs 325 case PERL_constant_ISYES: 326 EXTEND(SP, 1); 327 PUSHs(&PL_sv_undef); 328 PUSHs(&PL_sv_yes); 329 break; */ 330 default: 331 sv = sv_2mortal(newSVpvf( 332 "Unexpected return type %d while processing Socket macro %s, used", 333 type, s)); 334 PUSHs(sv); 335 } 336 #line 337 "Socket.c" 337 115 PUTBACK; 338 return; 339 } 340 } 341 342 343 /* INCLUDE: Returning to 'Socket.xs' from 'const-xs.inc' */ 344 345 346 XS(XS_Socket_inet_aton); /* prototype to pass -Wmissing-prototypes */ 347 XS(XS_Socket_inet_aton) 348 47 { 349 47 dXSARGS; 350 47 if (items != 1) 351 ###### Perl_croak(aTHX_ "Usage: Socket::inet_aton(host)"); 352 47 PERL_UNUSED_VAR(cv); /* -W */ 353 { 354 47 char * host = (char *)SvPV_nolen(ST(0)); 355 #line 231 "Socket.xs" 356 { 357 struct in_addr ip_address; 358 struct hostent * phe; 359 int ok = 360 (host != NULL) && 361 (*host != '\0') && 362 inet_aton(host, &ip_address); 363 364 if (!ok && (phe = gethostbyname(host))) { 365 Copy( phe->h_addr, &ip_address, phe->h_length, char ); 366 ok = 1; 367 } 368 369 ST(0) = sv_newmortal(); 370 if (ok) 371 sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address ); 372 } 373 #line 374 "Socket.c" 374 } 375 47 XSRETURN(1); 376 } 377 378 379 XS(XS_Socket_inet_ntoa); /* prototype to pass -Wmissing-prototypes */ 380 XS(XS_Socket_inet_ntoa) 381 10 { 382 10 dXSARGS; 383 10 if (items != 1) 384 ###### Perl_croak(aTHX_ "Usage: Socket::inet_ntoa(ip_address_sv)"); 385 10 PERL_UNUSED_VAR(cv); /* -W */ 386 { 387 10 SV * ip_address_sv = ST(0); 388 #line 253 "Socket.xs" 389 { 390 STRLEN addrlen; 391 struct in_addr addr; 392 char * addr_str; 393 char * ip_address; 394 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) 395 croak("Wide character in Socket::inet_ntoa"); 396 ip_address = SvPVbyte(ip_address_sv, addrlen); 397 if (addrlen == sizeof(addr) || addrlen == 4) 398 addr.s_addr = 399 (ip_address[0] & 0xFF) << 24 | 400 (ip_address[1] & 0xFF) << 16 | 401 (ip_address[2] & 0xFF) << 8 | 402 (ip_address[3] & 0xFF); 403 else 404 croak("Bad arg length for %s, length is %d, should be %d", 405 "Socket::inet_ntoa", 406 addrlen, sizeof(addr)); 407 /* We could use inet_ntoa() but that is broken 408 * in HP-UX + GCC + 64bitint (returns "0.0.0.0"), 409 * so let's use this sprintf() workaround everywhere. 410 * This is also more threadsafe than using inet_ntoa(). */ 411 New(1138, addr_str, 4 * 3 + 3 + 1, char); /* IPv6? */ 412 sprintf(addr_str, "%d.%d.%d.%d", 413 ((addr.s_addr >> 24) & 0xFF), 414 ((addr.s_addr >> 16) & 0xFF), 415 ((addr.s_addr >> 8) & 0xFF), 416 ( addr.s_addr & 0xFF)); 417 ST(0) = sv_2mortal(newSVpvn(addr_str, strlen(addr_str))); 418 Safefree(addr_str); 419 } 420 #line 421 "Socket.c" 421 } 422 9 XSRETURN(1); 423 } 424 425 426 XS(XS_Socket_sockaddr_family); /* prototype to pass -Wmissing-prototypes */ 427 XS(XS_Socket_sockaddr_family) 428 2 { 429 2 dXSARGS; 430 2 if (items != 1) 431 ###### Perl_croak(aTHX_ "Usage: Socket::sockaddr_family(sockaddr)"); 432 2 PERL_UNUSED_VAR(cv); /* -W */ 433 { 434 2 SV * sockaddr = ST(0); 435 #line 289 "Socket.xs" 436 STRLEN sockaddr_len; 437 char *sockaddr_pv = SvPVbyte(sockaddr, sockaddr_len); 438 #line 439 "Socket.c" 439 #line 292 "Socket.xs" 440 if (sockaddr_len < offsetof(struct sockaddr, sa_data)) { 441 croak("Bad arg length for %s, length is %d, should be at least %d", 442 "Socket::sockaddr_family", sockaddr_len, 443 offsetof(struct sockaddr, sa_data)); 444 } 445 ST(0) = sv_2mortal(newSViv(((struct sockaddr*)sockaddr_pv)->sa_family)); 446 #line 447 "Socket.c" 447 } 448 1 XSRETURN(1); 449 } 450 451 452 XS(XS_Socket_pack_sockaddr_un); /* prototype to pass -Wmissing-prototypes */ 453 XS(XS_Socket_pack_sockaddr_un) 454 5 { 455 5 dXSARGS; 456 5 if (items != 1) 457 ###### Perl_croak(aTHX_ "Usage: Socket::pack_sockaddr_un(pathname)"); 458 5 PERL_UNUSED_VAR(cv); /* -W */ 459 { 460 5 SV * pathname = ST(0); 461 #line 303 "Socket.xs" 462 { 463 #ifdef I_SYS_UN 464 struct sockaddr_un sun_ad; /* fear using sun */ 465 STRLEN len; 466 char * pathname_pv; 467 468 Zero( &sun_ad, sizeof sun_ad, char ); 469 sun_ad.sun_family = AF_UNIX; 470 pathname_pv = SvPV(pathname,len); 471 if (len > sizeof(sun_ad.sun_path)) 472 len = sizeof(sun_ad.sun_path); 473 # ifdef OS2 /* Name should start with \socket\ and contain backslashes! */ 474 { 475 int off; 476 char *s, *e; 477 478 if (pathname_pv[0] != '/' && pathname_pv[0] != '\\') 479 croak("Relative UNIX domain socket name '%s' unsupported", 480 pathname_pv); 481 else if (len < 8 482 || pathname_pv[7] != '/' && pathname_pv[7] != '\\' 483 || !strnicmp(pathname_pv + 1, "socket", 6)) 484 off = 7; 485 else 486 off = 0; /* Preserve names starting with \socket\ */ 487 Copy( "\\socket", sun_ad.sun_path, off, char); 488 Copy( pathname_pv, sun_ad.sun_path + off, len, char ); 489 490 s = sun_ad.sun_path + off - 1; 491 e = s + len + 1; 492 while (++s < e) 493 if (*s = '/') 494 *s = '\\'; 495 } 496 # else /* !( defined OS2 ) */ 497 Copy( pathname_pv, sun_ad.sun_path, len, char ); 498 # endif 499 if (0) not_here("dummy"); 500 ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad)); 501 #else 502 ST(0) = (SV *) not_here("pack_sockaddr_un"); 503 #endif 504 505 } 506 #line 507 "Socket.c" 507 } 508 5 XSRETURN(1); 509 } 510 511 512 XS(XS_Socket_unpack_sockaddr_un); /* prototype to pass -Wmissing-prototypes */ 513 XS(XS_Socket_unpack_sockaddr_un) 514 1 { 515 1 dXSARGS; 516 1 if (items != 1) 517 ###### Perl_croak(aTHX_ "Usage: Socket::unpack_sockaddr_un(sun_sv)"); 518 1 PERL_UNUSED_VAR(cv); /* -W */ 519 { 520 1 SV * sun_sv = ST(0); 521 #line 352 "Socket.xs" 522 { 523 #ifdef I_SYS_UN 524 struct sockaddr_un addr; 525 STRLEN sockaddrlen; 526 char * sun_ad = SvPVbyte(sun_sv,sockaddrlen); 527 char * e; 528 # ifndef __linux__ 529 /* On Linux sockaddrlen on sockets returned by accept, recvfrom, 530 getpeername and getsockname is not equal to sizeof(addr). */ 531 if (sockaddrlen != sizeof(addr)) { 532 croak("Bad arg length for %s, length is %d, should be %d", 533 "Socket::unpack_sockaddr_un", 534 sockaddrlen, sizeof(addr)); 535 } 536 # endif 537 538 Copy( sun_ad, &addr, sizeof addr, char ); 539 540 if ( addr.sun_family != AF_UNIX ) { 541 croak("Bad address family for %s, got %d, should be %d", 542 "Socket::unpack_sockaddr_un", 543 addr.sun_family, 544 AF_UNIX); 545 } 546 e = (char*)addr.sun_path; 547 /* On Linux, the name of abstract unix domain sockets begins 548 * with a '\0', so allow this. */ 549 while ((*e || (e == addr.sun_path && e[1] && sockaddrlen > 1)) 550 && e < (char*)addr.sun_path + sizeof addr.sun_path) 551 ++e; 552 ST(0) = sv_2mortal(newSVpvn(addr.sun_path, e - (char*)addr.sun_path)); 553 #else 554 ST(0) = (SV *) not_here("unpack_sockaddr_un"); 555 #endif 556 } 557 #line 558 "Socket.c" 558 } 559 1 XSRETURN(1); 560 } 561 562 563 XS(XS_Socket_pack_sockaddr_in); /* prototype to pass -Wmissing-prototypes */ 564 XS(XS_Socket_pack_sockaddr_in) 565 59 { 566 59 dXSARGS; 567 59 if (items != 2) 568 ###### Perl_croak(aTHX_ "Usage: Socket::pack_sockaddr_in(port, ip_address_sv)"); 569 59 PERL_UNUSED_VAR(cv); /* -W */ 570 { 571 59 unsigned short port = (unsigned short)SvUV(ST(0)); 572 59 SV * ip_address_sv = ST(1); 573 #line 393 "Socket.xs" 574 { 575 struct sockaddr_in sin; 576 struct in_addr addr; 577 STRLEN addrlen; 578 char * ip_address; 579 if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) 580 croak("Wide character in Socket::pack_sockaddr_in"); 581 ip_address = SvPVbyte(ip_address_sv, addrlen); 582 if (addrlen == sizeof(addr) || addrlen == 4) 583 addr.s_addr = 584 (ip_address[0] & 0xFF) << 24 | 585 (ip_address[1] & 0xFF) << 16 | 586 (ip_address[2] & 0xFF) << 8 | 587 (ip_address[3] & 0xFF); 588 else 589 croak("Bad arg length for %s, length is %d, should be %d", 590 "Socket::pack_sockaddr_in", 591 addrlen, sizeof(addr)); 592 Zero( &sin, sizeof sin, char ); 593 sin.sin_family = AF_INET; 594 sin.sin_port = htons(port); 595 sin.sin_addr.s_addr = htonl(addr.s_addr); 596 ST(0) = sv_2mortal(newSVpvn((char *)&sin, sizeof sin)); 597 } 598 #line 599 "Socket.c" 599 } 600 59 XSRETURN(1); 601 } 602 603 604 XS(XS_Socket_unpack_sockaddr_in); /* prototype to pass -Wmissing-prototypes */ 605 XS(XS_Socket_unpack_sockaddr_in) 606 27 { 607 27 dXSARGS; 608 27 if (items != 1) 609 ###### Perl_croak(aTHX_ "Usage: Socket::unpack_sockaddr_in(sin_sv)"); 610 27 PERL_UNUSED_VAR(cv); /* -W */ 611 27 PERL_UNUSED_VAR(ax); /* -Wall */ 612 27 SP -= items; 613 { 614 27 SV * sin_sv = ST(0); 615 #line 422 "Socket.xs" 616 { 617 STRLEN sockaddrlen; 618 struct sockaddr_in addr; 619 unsigned short port; 620 struct in_addr ip_address; 621 char * sin = SvPVbyte(sin_sv,sockaddrlen); 622 if (sockaddrlen != sizeof(addr)) { 623 croak("Bad arg length for %s, length is %d, should be %d", 624 "Socket::unpack_sockaddr_in", 625 sockaddrlen, sizeof(addr)); 626 } 627 Copy( sin, &addr,sizeof addr, char ); 628 if ( addr.sin_family != AF_INET ) { 629 croak("Bad address family for %s, got %d, should be %d", 630 "Socket::unpack_sockaddr_in", 631 addr.sin_family, 632 AF_INET); 633 } 634 port = ntohs(addr.sin_port); 635 ip_address = addr.sin_addr; 636 637 EXTEND(SP, 2); 638 PUSHs(sv_2mortal(newSViv((IV) port))); 639 PUSHs(sv_2mortal(newSVpvn((char *)&ip_address, sizeof ip_address))); 640 } 641 #line 642 "Socket.c" 642 27 PUTBACK; 643 return; 644 } 645 } 646 647 #ifdef __cplusplus 648 extern "C" 649 #endif 650 XS(boot_Socket); /* prototype to pass -Wmissing-prototypes */ 651 XS(boot_Socket) 652 38 { 653 38 dXSARGS; 654 38 char* file = __FILE__; 655 656 38 PERL_UNUSED_VAR(cv); /* -W */ 657 38 PERL_UNUSED_VAR(items); /* -W */ 658 38 XS_VERSION_BOOTCHECK ; 659 660 38 newXS("Socket::constant", XS_Socket_constant, file); 661 38 newXS("Socket::inet_aton", XS_Socket_inet_aton, file); 662 38 newXS("Socket::inet_ntoa", XS_Socket_inet_ntoa, file); 663 38 newXS("Socket::sockaddr_family", XS_Socket_sockaddr_family, file); 664 38 newXS("Socket::pack_sockaddr_un", XS_Socket_pack_sockaddr_un, file); 665 38 newXS("Socket::unpack_sockaddr_un", XS_Socket_unpack_sockaddr_un, file); 666 38 newXS("Socket::pack_sockaddr_in", XS_Socket_pack_sockaddr_in, file); 667 38 newXS("Socket::unpack_sockaddr_in", XS_Socket_unpack_sockaddr_in, file); 668 38 XSRETURN_YES; 669 } 670