1 #define PERL_EXT_POSIX 2 #define PERL_EXT 3 4 #ifdef NETWARE 5 #define _POSIX_ 6 /* 7 * Ideally this should be somewhere down in the includes 8 * but putting it in other places is giving compiler errors. 9 * Also here I am unable to check for HAS_UNAME since it wouldn't have 10 * yet come into the file at this stage - sgp 18th Oct 2000 11 */ 12 #include <sys/utsname.h> 13 #endif /* NETWARE */ 14 15 #define PERL_NO_GET_CONTEXT 16 17 #include "EXTERN.h" 18 #define PERLIO_NOT_STDIO 1 19 #include "perl.h" 20 #include "XSUB.h" 21 22 static int not_here(const char *s); 23 24 #if defined(PERL_IMPLICIT_SYS) 25 # undef signal 26 # undef open 27 # undef setmode 28 # define open PerlLIO_open3 29 #endif 30 #include <ctype.h> 31 #ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */ 32 #include <dirent.h> 33 #endif 34 #include <errno.h> 35 #ifdef WIN32 36 #include <sys/errno2.h> 37 #endif 38 #include <float.h> 39 #ifdef I_FENV 40 #if !(defined(__vax__) && defined(__NetBSD__)) 41 #include <fenv.h> 42 #endif 43 #endif 44 #include <limits.h> 45 #include <locale.h> 46 #include <math.h> 47 #ifdef I_PWD 48 #include <pwd.h> 49 #endif 50 #include <setjmp.h> 51 #include <signal.h> 52 #include <stdarg.h> 53 #include <stddef.h> 54 55 #ifdef I_UNISTD 56 #include <unistd.h> 57 #endif 58 59 #ifdef I_SYS_TIME 60 # include <sys/time.h> 61 #endif 62 63 #ifdef I_SYS_RESOURCE 64 # include <sys/resource.h> 65 #endif 66 67 /* Cygwin's stdio.h doesn't make cuserid() visible with -D_GNU_SOURCE, 68 unlike Linux. 69 */ 70 #ifdef __CYGWIN__ 71 # undef HAS_CUSERID 72 #endif 73 74 #if defined(USE_QUADMATH) && defined(I_QUADMATH) 75 76 # undef M_E 77 # undef M_LOG2E 78 # undef M_LOG10E 79 # undef M_LN2 80 # undef M_LN10 81 # undef M_PI 82 # undef M_PI_2 83 # undef M_PI_4 84 # undef M_1_PI 85 # undef M_2_PI 86 # undef M_2_SQRTPI 87 # undef M_SQRT2 88 # undef M_SQRT1_2 89 90 # define M_E M_Eq 91 # define M_LOG2E M_LOG2Eq 92 # define M_LOG10E M_LOG10Eq 93 # define M_LN2 M_LN2q 94 # define M_LN10 M_LN10q 95 # define M_PI M_PIq 96 # define M_PI_2 M_PI_2q 97 # define M_PI_4 M_PI_4q 98 # define M_1_PI M_1_PIq 99 # define M_2_PI M_2_PIq 100 # define M_2_SQRTPI M_2_SQRTPIq 101 # define M_SQRT2 M_SQRT2q 102 # define M_SQRT1_2 M_SQRT1_2q 103 104 #else 105 106 # ifdef USE_LONG_DOUBLE 107 # undef M_E 108 # undef M_LOG2E 109 # undef M_LOG10E 110 # undef M_LN2 111 # undef M_LN10 112 # undef M_PI 113 # undef M_PI_2 114 # undef M_PI_4 115 # undef M_1_PI 116 # undef M_2_PI 117 # undef M_2_SQRTPI 118 # undef M_SQRT2 119 # undef M_SQRT1_2 120 # define FLOAT_C(c) CAT2(c,L) 121 # else 122 # define FLOAT_C(c) (c) 123 # endif 124 125 # ifndef M_E 126 # define M_E FLOAT_C(2.71828182845904523536028747135266250) 127 # endif 128 # ifndef M_LOG2E 129 # define M_LOG2E FLOAT_C(1.44269504088896340735992468100189214) 130 # endif 131 # ifndef M_LOG10E 132 # define M_LOG10E FLOAT_C(0.434294481903251827651128918916605082) 133 # endif 134 # ifndef M_LN2 135 # define M_LN2 FLOAT_C(0.693147180559945309417232121458176568) 136 # endif 137 # ifndef M_LN10 138 # define M_LN10 FLOAT_C(2.30258509299404568401799145468436421) 139 # endif 140 # ifndef M_PI 141 # define M_PI FLOAT_C(3.14159265358979323846264338327950288) 142 # endif 143 # ifndef M_PI_2 144 # define M_PI_2 FLOAT_C(1.57079632679489661923132169163975144) 145 # endif 146 # ifndef M_PI_4 147 # define M_PI_4 FLOAT_C(0.785398163397448309615660845819875721) 148 # endif 149 # ifndef M_1_PI 150 # define M_1_PI FLOAT_C(0.318309886183790671537767526745028724) 151 # endif 152 # ifndef M_2_PI 153 # define M_2_PI FLOAT_C(0.636619772367581343075535053490057448) 154 # endif 155 # ifndef M_2_SQRTPI 156 # define M_2_SQRTPI FLOAT_C(1.12837916709551257389615890312154517) 157 # endif 158 # ifndef M_SQRT2 159 # define M_SQRT2 FLOAT_C(1.41421356237309504880168872420969808) 160 # endif 161 # ifndef M_SQRT1_2 162 # define M_SQRT1_2 FLOAT_C(0.707106781186547524400844362104849039) 163 # endif 164 165 #endif 166 167 #if !defined(INFINITY) && defined(NV_INF) 168 # define INFINITY NV_INF 169 #endif 170 171 #if !defined(NAN) && defined(NV_NAN) 172 # define NAN NV_NAN 173 #endif 174 175 #if !defined(Inf) && defined(NV_INF) 176 # define Inf NV_INF 177 #endif 178 179 #if !defined(NaN) && defined(NV_NAN) 180 # define NaN NV_NAN 181 #endif 182 183 /* We will have an emulation. */ 184 #ifndef FP_INFINITE 185 # define FP_INFINITE 0 186 # define FP_NAN 1 187 # define FP_NORMAL 2 188 # define FP_SUBNORMAL 3 189 # define FP_ZERO 4 190 #endif 191 192 /* We will have an emulation. */ 193 #ifndef FE_TONEAREST 194 # define FE_TOWARDZERO 0 195 # define FE_TONEAREST 1 196 # define FE_UPWARD 2 197 # define FE_DOWNWARD 3 198 #endif 199 200 /* C89 math.h: 201 202 acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp 203 log log10 modf pow sin sinh sqrt tan tanh 204 205 * Implemented in core: 206 207 atan2 cos exp log pow sin sqrt 208 209 * C99 math.h added: 210 211 acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax 212 fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf 213 isless islessequal islessgreater isnan isnormal isunordered lgamma 214 log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder 215 remquo rint round scalbn signbit tgamma trunc 216 217 See: 218 http://pubs.opengroup.org/onlinepubs/009695399/basedefs/math.h.html 219 220 * Berkeley/SVID extensions: 221 222 j0 j1 jn y0 y1 yn 223 224 * Configure already (5.21.5) scans for: 225 226 copysign*l* fpclassify isfinite isinf isnan isnan*l* ilogb*l* signbit scalbn*l* 227 228 * For floating-point round mode (which matters for e.g. lrint and rint) 229 230 fegetround fesetround 231 232 */ 233 234 /* XXX Constant FP_FAST_FMA (if true, FMA is faster) */ 235 236 /* XXX Add ldiv(), lldiv()? It's C99, but from stdlib.h, not math.h */ 237 238 /* XXX Beware old gamma() -- one cannot know whether that is the 239 * gamma or the log of gamma, that's why the new tgamma and lgamma. 240 * Though also remember lgamma_r. */ 241 242 /* Certain AIX releases have the C99 math, but not in long double. 243 * The <math.h> has them, e.g. __expl128, but no library has them! 244 * 245 * Also see the comments in hints/aix.sh about long doubles. */ 246 247 #if defined(USE_QUADMATH) && defined(I_QUADMATH) 248 # define c99_acosh acoshq 249 # define c99_asinh asinhq 250 # define c99_atanh atanhq 251 # define c99_cbrt cbrtq 252 # define c99_copysign copysignq 253 # define c99_erf erfq 254 # define c99_erfc erfcq 255 /* no exp2q */ 256 # define c99_expm1 expm1q 257 # define c99_fdim fdimq 258 # define c99_fma fmaq 259 # define c99_fmax fmaxq 260 # define c99_fmin fminq 261 # define c99_hypot hypotq 262 # define c99_ilogb ilogbq 263 # define c99_lgamma lgammaq 264 # define c99_log1p log1pq 265 # define c99_log2 log2q 266 /* no logbq */ 267 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG 268 # define c99_lrint llrintq 269 # define c99_lround llroundq 270 # else 271 # define c99_lrint lrintq 272 # define c99_lround lroundq 273 # endif 274 # define c99_nan nanq 275 # define c99_nearbyint nearbyintq 276 # define c99_nextafter nextafterq 277 /* no nexttowardq */ 278 # define c99_remainder remainderq 279 # define c99_remquo remquoq 280 # define c99_rint rintq 281 # define c99_round roundq 282 # define c99_scalbn scalbnq 283 # define c99_signbit signbitq 284 # define c99_tgamma tgammaq 285 # define c99_trunc truncq 286 # define bessel_j0 j0q 287 # define bessel_j1 j1q 288 # define bessel_jn jnq 289 # define bessel_y0 y0q 290 # define bessel_y1 y1q 291 # define bessel_yn ynq 292 #elif defined(USE_LONG_DOUBLE) && \ 293 (defined(HAS_FREXPL) || defined(HAS_ILOGBL)) && defined(HAS_SQRTL) 294 /* Use some of the Configure scans for long double math functions 295 * as the canary for all the C99 *l variants being defined. */ 296 # define c99_acosh acoshl 297 # define c99_asinh asinhl 298 # define c99_atanh atanhl 299 # define c99_cbrt cbrtl 300 # define c99_copysign copysignl 301 # define c99_erf erfl 302 # define c99_erfc erfcl 303 # define c99_exp2 exp2l 304 # define c99_expm1 expm1l 305 # define c99_fdim fdiml 306 # define c99_fma fmal 307 # define c99_fmax fmaxl 308 # define c99_fmin fminl 309 # define c99_hypot hypotl 310 # define c99_ilogb ilogbl 311 # define c99_lgamma lgammal 312 # define c99_log1p log1pl 313 # define c99_log2 log2l 314 # define c99_logb logbl 315 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINTL) 316 # define c99_lrint llrintl 317 # elif defined(HAS_LRINTL) 318 # define c99_lrint lrintl 319 # endif 320 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUNDL) 321 # define c99_lround llroundl 322 # elif defined(HAS_LROUNDL) 323 # define c99_lround lroundl 324 # endif 325 # define c99_nan nanl 326 # define c99_nearbyint nearbyintl 327 # define c99_nextafter nextafterl 328 # define c99_nexttoward nexttowardl 329 # define c99_remainder remainderl 330 # define c99_remquo remquol 331 # define c99_rint rintl 332 # define c99_round roundl 333 # define c99_scalbn scalbnl 334 # ifdef HAS_SIGNBIT /* possibly bad assumption */ 335 # define c99_signbit signbitl 336 # endif 337 # define c99_tgamma tgammal 338 # define c99_trunc truncl 339 #else 340 # define c99_acosh acosh 341 # define c99_asinh asinh 342 # define c99_atanh atanh 343 # define c99_cbrt cbrt 344 # define c99_copysign copysign 345 # define c99_erf erf 346 # define c99_erfc erfc 347 # define c99_exp2 exp2 348 # define c99_expm1 expm1 349 # define c99_fdim fdim 350 # define c99_fma fma 351 # define c99_fmax fmax 352 # define c99_fmin fmin 353 # define c99_hypot hypot 354 # define c99_ilogb ilogb 355 # define c99_lgamma lgamma 356 # define c99_log1p log1p 357 # define c99_log2 log2 358 # define c99_logb logb 359 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINT) 360 # define c99_lrint llrint 361 # else 362 # define c99_lrint lrint 363 # endif 364 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUND) 365 # define c99_lround llround 366 # else 367 # define c99_lround lround 368 # endif 369 # define c99_nan nan 370 # define c99_nearbyint nearbyint 371 # define c99_nextafter nextafter 372 # define c99_nexttoward nexttoward 373 # define c99_remainder remainder 374 # define c99_remquo remquo 375 # define c99_rint rint 376 # define c99_round round 377 # define c99_scalbn scalbn 378 /* We already define Perl_signbit in perl.h. */ 379 # ifdef HAS_SIGNBIT 380 # define c99_signbit signbit 381 # endif 382 # define c99_tgamma tgamma 383 # define c99_trunc trunc 384 #endif 385 386 /* AIX xlc (__IBMC__) really doesn't have the following long double 387 * math interfaces (no __acoshl128 aka acoshl, etc.), see 388 * hints/aix.sh. These are in the -lc128 but fail to be found 389 * during dynamic linking/loading. 390 * 391 * XXX1 Better Configure scans 392 * XXX2 Is this xlc version dependent? */ 393 #if defined(USE_LONG_DOUBLE) && defined(__IBMC__) 394 # undef c99_acosh 395 # undef c99_asinh 396 # undef c99_atanh 397 # undef c99_cbrt 398 # undef c99_copysign 399 # undef c99_exp2 400 # undef c99_expm1 401 # undef c99_fdim 402 # undef c99_fma 403 # undef c99_fmax 404 # undef c99_fmin 405 # undef c99_hypot 406 # undef c99_ilogb 407 # undef c99_lrint 408 # undef c99_lround 409 # undef c99_log1p 410 # undef c99_log2 411 # undef c99_logb 412 # undef c99_nan 413 # undef c99_nearbyint 414 # undef c99_nextafter 415 # undef c99_nexttoward 416 # undef c99_remainder 417 # undef c99_remquo 418 # undef c99_rint 419 # undef c99_round 420 # undef c99_scalbn 421 # undef c99_tgamma 422 # undef c99_trunc 423 #endif 424 425 #ifndef isunordered 426 # ifdef Perl_isnan 427 # define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y)) 428 # elif defined(HAS_UNORDERED) 429 # define isunordered(x, y) unordered(x, y) 430 # endif 431 #endif 432 433 /* XXX these isgreater/isnormal/isunordered macros definitions should 434 * be moved further in the file to be part of the emulations, so that 435 * platforms can e.g. #undef c99_isunordered and have it work like 436 * it does for the other interfaces. */ 437 438 #if !defined(isgreater) && defined(isunordered) 439 # define isgreater(x, y) (!isunordered((x), (y)) && (x) > (y)) 440 # define isgreaterequal(x, y) (!isunordered((x), (y)) && (x) >= (y)) 441 # define isless(x, y) (!isunordered((x), (y)) && (x) < (y)) 442 # define islessequal(x, y) (!isunordered((x), (y)) && (x) <= (y)) 443 # define islessgreater(x, y) (!isunordered((x), (y)) && \ 444 ((x) > (y) || (y) > (x))) 445 #endif 446 447 /* Check both the Configure symbol and the macro-ness (like C99 promises). */ 448 #if defined(HAS_FPCLASSIFY) && defined(fpclassify) 449 # define c99_fpclassify fpclassify 450 #endif 451 /* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99 452 and also (sizeof-arg-aware) macros, but they are already well taken 453 care of by Configure et al, and defined in perl.h as 454 Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */ 455 #ifdef isnormal 456 # define c99_isnormal isnormal 457 #endif 458 #ifdef isgreater /* canary for all the C99 is*<cmp>* macros. */ 459 # define c99_isgreater isgreater 460 # define c99_isgreaterequal isgreaterequal 461 # define c99_isless isless 462 # define c99_islessequal islessequal 463 # define c99_islessgreater islessgreater 464 # define c99_isunordered isunordered 465 #endif 466 467 /* The Great Wall of Undef where according to the definedness of HAS_FOO symbols 468 * the corresponding c99_foo wrappers are undefined. This list doesn't include 469 * the isfoo() interfaces because they are either type-aware macros, or dealt 470 * separately, already in perl.h */ 471 472 #ifndef HAS_ACOSH 473 # undef c99_acosh 474 #endif 475 #ifndef HAS_ASINH 476 # undef c99_asinh 477 #endif 478 #ifndef HAS_ATANH 479 # undef c99_atanh 480 #endif 481 #ifndef HAS_CBRT 482 # undef c99_cbrt 483 #endif 484 #ifndef HAS_COPYSIGN 485 # undef c99_copysign 486 #endif 487 #ifndef HAS_ERF 488 # undef c99_erf 489 #endif 490 #ifndef HAS_ERFC 491 # undef c99_erfc 492 #endif 493 #ifndef HAS_EXP2 494 # undef c99_exp2 495 #endif 496 #ifndef HAS_EXPM1 497 # undef c99_expm1 498 #endif 499 #ifndef HAS_FDIM 500 # undef c99_fdim 501 #endif 502 #ifndef HAS_FMA 503 # undef c99_fma 504 #endif 505 #ifndef HAS_FMAX 506 # undef c99_fmax 507 #endif 508 #ifndef HAS_FMIN 509 # undef c99_fmin 510 #endif 511 #ifndef HAS_FPCLASSIFY 512 # undef c99_fpclassify 513 #endif 514 #ifndef HAS_HYPOT 515 # undef c99_hypot 516 #endif 517 #ifndef HAS_ILOGB 518 # undef c99_ilogb 519 #endif 520 #ifndef HAS_LGAMMA 521 # undef c99_lgamma 522 #endif 523 #ifndef HAS_LOG1P 524 # undef c99_log1p 525 #endif 526 #ifndef HAS_LOG2 527 # undef c99_log2 528 #endif 529 #ifndef HAS_LOGB 530 # undef c99_logb 531 #endif 532 #ifndef HAS_LRINT 533 # undef c99_lrint 534 #endif 535 #ifndef HAS_LROUND 536 # undef c99_lround 537 #endif 538 #ifndef HAS_NAN 539 # undef c99_nan 540 #endif 541 #ifndef HAS_NEARBYINT 542 # undef c99_nearbyint 543 #endif 544 #ifndef HAS_NEXTAFTER 545 # undef c99_nextafter 546 #endif 547 #ifndef HAS_NEXTTOWARD 548 # undef c99_nexttoward 549 #endif 550 #ifndef HAS_REMAINDER 551 # undef c99_remainder 552 #endif 553 #ifndef HAS_REMQUO 554 # undef c99_remquo 555 #endif 556 #ifndef HAS_RINT 557 # undef c99_rint 558 #endif 559 #ifndef HAS_ROUND 560 # undef c99_round 561 #endif 562 #ifndef HAS_SCALBN 563 # undef c99_scalbn 564 #endif 565 #ifndef HAS_SIGNBIT 566 # undef c99_signbit 567 #endif 568 #ifndef HAS_TGAMMA 569 # undef c99_tgamma 570 #endif 571 #ifndef HAS_TRUNC 572 # undef c99_trunc 573 #endif 574 575 #ifdef _MSC_VER 576 577 /* Some APIs exist under Win32 with "underbar" names. */ 578 # undef c99_hypot 579 # undef c99_logb 580 # undef c99_nextafter 581 # define c99_hypot _hypot 582 # define c99_logb _logb 583 # define c99_nextafter _nextafter 584 585 # define bessel_j0 _j0 586 # define bessel_j1 _j1 587 # define bessel_jn _jn 588 # define bessel_y0 _y0 589 # define bessel_y1 _y1 590 # define bessel_yn _yn 591 592 #endif 593 594 /* The Bessel functions: BSD, SVID, XPG4, and POSIX. But not C99. */ 595 #if defined(HAS_J0) && !defined(bessel_j0) 596 # if defined(USE_LONG_DOUBLE) && defined(HAS_J0L) 597 # define bessel_j0 j0l 598 # define bessel_j1 j1l 599 # define bessel_jn jnl 600 # define bessel_y0 y0l 601 # define bessel_y1 y1l 602 # define bessel_yn ynl 603 # else 604 # define bessel_j0 j0 605 # define bessel_j1 j1 606 # define bessel_jn jn 607 # define bessel_y0 y0 608 # define bessel_y1 y1 609 # define bessel_yn yn 610 # endif 611 #endif 612 613 /* Emulations for missing math APIs. 614 * 615 * Keep in mind that the point of many of these functions is that 616 * they, if available, are supposed to give more precise/more 617 * numerically stable results. 618 * 619 * See e.g. http://www.johndcook.com/math_h.html 620 */ 621 622 #ifndef c99_acosh 623 static NV my_acosh(NV x) 624 { 625 return Perl_log(x + Perl_sqrt(x * x - 1)); 626 } 627 # define c99_acosh my_acosh 628 #endif 629 630 #ifndef c99_asinh 631 static NV my_asinh(NV x) 632 { 633 return Perl_log(x + Perl_sqrt(x * x + 1)); 634 } 635 # define c99_asinh my_asinh 636 #endif 637 638 #ifndef c99_atanh 639 static NV my_atanh(NV x) 640 { 641 return (Perl_log(1 + x) - Perl_log(1 - x)) / 2; 642 } 643 # define c99_atanh my_atanh 644 #endif 645 646 #ifndef c99_cbrt 647 static NV my_cbrt(NV x) 648 { 649 static const NV one_third = (NV)1.0/3; 650 return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third); 651 } 652 # define c99_cbrt my_cbrt 653 #endif 654 655 #ifndef c99_copysign 656 static NV my_copysign(NV x, NV y) 657 { 658 return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x); 659 } 660 # define c99_copysign my_copysign 661 #endif 662 663 /* XXX cosh (though c89) */ 664 665 #ifndef c99_erf 666 static NV my_erf(NV x) 667 { 668 /* http://www.johndcook.com/cpp_erf.html -- public domain */ 669 NV a1 = 0.254829592; 670 NV a2 = -0.284496736; 671 NV a3 = 1.421413741; 672 NV a4 = -1.453152027; 673 NV a5 = 1.061405429; 674 NV p = 0.3275911; 675 NV t, y; 676 int sign = x < 0 ? -1 : 1; /* Save the sign. */ 677 x = PERL_ABS(x); 678 679 /* Abramowitz and Stegun formula 7.1.26 */ 680 t = 1.0 / (1.0 + p * x); 681 y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * Perl_exp(-x*x); 682 683 return sign * y; 684 } 685 # define c99_erf my_erf 686 #endif 687 688 #ifndef c99_erfc 689 static NV my_erfc(NV x) { 690 /* This is not necessarily numerically stable, but better than nothing. */ 691 return 1.0 - c99_erf(x); 692 } 693 # define c99_erfc my_erfc 694 #endif 695 696 #ifndef c99_exp2 697 static NV my_exp2(NV x) 698 { 699 return Perl_pow((NV)2.0, x); 700 } 701 # define c99_exp2 my_exp2 702 #endif 703 704 #ifndef c99_expm1 705 static NV my_expm1(NV x) 706 { 707 if (PERL_ABS(x) < 1e-5) 708 /* http://www.johndcook.com/cpp_expm1.html -- public domain. 709 * Taylor series, the first four terms (the last term quartic). */ 710 /* Probably not enough for long doubles. */ 711 return x * (1.0 + x * (1/2.0 + x * (1/6.0 + x/24.0))); 712 else 713 return Perl_exp(x) - 1; 714 } 715 # define c99_expm1 my_expm1 716 #endif 717 718 #ifndef c99_fdim 719 static NV my_fdim(NV x, NV y) 720 { 721 #ifdef NV_NAN 722 return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0); 723 #else 724 return (x > y ? x - y : 0); 725 #endif 726 } 727 # define c99_fdim my_fdim 728 #endif 729 730 #ifndef c99_fma 731 static NV my_fma(NV x, NV y, NV z) 732 { 733 return (x * y) + z; 734 } 735 # define c99_fma my_fma 736 #endif 737 738 #ifndef c99_fmax 739 static NV my_fmax(NV x, NV y) 740 { 741 #ifdef NV_NAN 742 if (Perl_isnan(x)) { 743 return Perl_isnan(y) ? NV_NAN : y; 744 } else if (Perl_isnan(y)) { 745 return x; 746 } 747 #endif 748 return x > y ? x : y; 749 } 750 # define c99_fmax my_fmax 751 #endif 752 753 #ifndef c99_fmin 754 static NV my_fmin(NV x, NV y) 755 { 756 #ifdef NV_NAN 757 if (Perl_isnan(x)) { 758 return Perl_isnan(y) ? NV_NAN : y; 759 } else if (Perl_isnan(y)) { 760 return x; 761 } 762 #endif 763 return x < y ? x : y; 764 } 765 # define c99_fmin my_fmin 766 #endif 767 768 #ifndef c99_fpclassify 769 770 static IV my_fpclassify(NV x) 771 { 772 #ifdef Perl_fp_class_inf 773 if (Perl_fp_class_inf(x)) return FP_INFINITE; 774 if (Perl_fp_class_nan(x)) return FP_NAN; 775 if (Perl_fp_class_norm(x)) return FP_NORMAL; 776 if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL; 777 if (Perl_fp_class_zero(x)) return FP_ZERO; 778 # define c99_fpclassify my_fpclassify 779 #endif 780 return -1; 781 } 782 783 #endif 784 785 #ifndef c99_hypot 786 static NV my_hypot(NV x, NV y) 787 { 788 /* http://en.wikipedia.org/wiki/Hypot */ 789 NV t; 790 x = PERL_ABS(x); /* Take absolute values. */ 791 if (y == 0) 792 return x; 793 #ifdef NV_INF 794 if (Perl_isnan(y)) 795 return NV_INF; 796 #endif 797 y = PERL_ABS(y); 798 if (x < y) { /* Swap so that y is less. */ 799 t = x; 800 x = y; 801 y = t; 802 } 803 t = y / x; 804 return x * Perl_sqrt(1.0 + t * t); 805 } 806 # define c99_hypot my_hypot 807 #endif 808 809 #ifndef c99_ilogb 810 static IV my_ilogb(NV x) 811 { 812 return (IV)(Perl_log(x) * M_LOG2E); 813 } 814 # define c99_ilogb my_ilogb 815 #endif 816 817 /* tgamma and lgamma emulations based on 818 * http://www.johndcook.com/cpp_gamma.html, 819 * code placed in public domain. 820 * 821 * Note that these implementations (neither the johndcook originals 822 * nor these) do NOT set the global signgam variable. This is not 823 * necessarily a bad thing. */ 824 825 /* Note that the tgamma() and lgamma() implementations 826 * here depend on each other. */ 827 828 #if !defined(HAS_TGAMMA) || !defined(c99_tgamma) 829 static NV my_tgamma(NV x); 830 # define c99_tgamma my_tgamma 831 # define USE_MY_TGAMMA 832 #endif 833 #if !defined(HAS_LGAMMA) || !defined(c99_lgamma) 834 static NV my_lgamma(NV x); 835 # define c99_lgamma my_lgamma 836 # define USE_MY_LGAMMA 837 #endif 838 839 #ifdef USE_MY_TGAMMA 840 static NV my_tgamma(NV x) 841 { 842 const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */ 843 #ifdef NV_NAN 844 if (Perl_isnan(x) || x < 0.0) 845 return NV_NAN; 846 #endif 847 #ifdef NV_INF 848 if (x == 0.0 || x == NV_INF) 849 #ifdef DOUBLE_IS_IEEE_FORMAT 850 return x == -0.0 ? -NV_INF : NV_INF; 851 #else 852 return NV_INF; 853 #endif 854 #endif 855 856 /* The function domain is split into three intervals: 857 * (0, 0.001), [0.001, 12), and (12, infinity) */ 858 859 /* First interval: (0, 0.001) 860 * For small values, 1/tgamma(x) has power series x + gamma x^2, 861 * so in this range, 1/tgamma(x) = x + gamma x^2 with error on the order of x^3. 862 * The relative error over this interval is less than 6e-7. */ 863 if (x < 0.001) 864 return 1.0 / (x * (1.0 + gamma * x)); 865 866 /* Second interval: [0.001, 12) */ 867 if (x < 12.0) { 868 double y = x; /* Working copy. */ 869 int n = 0; 870 /* Numerator coefficients for approximation over the interval (1,2) */ 871 static const NV p[] = { 872 -1.71618513886549492533811E+0, 873 2.47656508055759199108314E+1, 874 -3.79804256470945635097577E+2, 875 6.29331155312818442661052E+2, 876 8.66966202790413211295064E+2, 877 -3.14512729688483675254357E+4, 878 -3.61444134186911729807069E+4, 879 6.64561438202405440627855E+4 880 }; 881 /* Denominator coefficients for approximation over the interval (1, 2) */ 882 static const NV q[] = { 883 -3.08402300119738975254353E+1, 884 3.15350626979604161529144E+2, 885 -1.01515636749021914166146E+3, 886 -3.10777167157231109440444E+3, 887 2.25381184209801510330112E+4, 888 4.75584627752788110767815E+3, 889 -1.34659959864969306392456E+5, 890 -1.15132259675553483497211E+5 891 }; 892 NV num = 0.0; 893 NV den = 1.0; 894 NV z; 895 NV result; 896 int i; 897 898 if (x < 1.0) 899 y += 1.0; 900 else { 901 n = (int)Perl_floor(y) - 1; 902 y -= n; 903 } 904 z = y - 1; 905 for (i = 0; i < 8; i++) { 906 num = (num + p[i]) * z; 907 den = den * z + q[i]; 908 } 909 result = num / den + 1.0; 910 911 if (x < 1.0) { 912 /* Use the identity tgamma(z) = tgamma(z+1)/z 913 * The variable "result" now holds tgamma of the original y + 1 914 * Thus we use y - 1 to get back the original y. */ 915 result /= (y - 1.0); 916 } 917 else { 918 /* Use the identity tgamma(z+n) = z*(z+1)* ... *(z+n-1)*tgamma(z) */ 919 for (i = 0; i < n; i++) 920 result *= y++; 921 } 922 923 return result; 924 } 925 926 #ifdef NV_INF 927 /* Third interval: [12, +Inf) */ 928 #if LDBL_MANT_DIG == 113 /* IEEE quad prec */ 929 if (x > 1755.548) { 930 return NV_INF; 931 } 932 #else 933 if (x > 171.624) { 934 return NV_INF; 935 } 936 #endif 937 #endif 938 939 return Perl_exp(c99_lgamma(x)); 940 } 941 #endif 942 943 #ifdef USE_MY_LGAMMA 944 static NV my_lgamma(NV x) 945 { 946 #ifdef NV_NAN 947 if (Perl_isnan(x)) 948 return NV_NAN; 949 #endif 950 #ifdef NV_INF 951 if (x <= 0 || x == NV_INF) 952 return NV_INF; 953 #endif 954 if (x == 1.0 || x == 2.0) 955 return 0; 956 if (x < 12.0) 957 return Perl_log(PERL_ABS(c99_tgamma(x))); 958 /* Abramowitz and Stegun 6.1.41 959 * Asymptotic series should be good to at least 11 or 12 figures 960 * For error analysis, see Whittiker and Watson 961 * A Course in Modern Analysis (1927), page 252 */ 962 { 963 static const NV c[8] = { 964 1.0/12.0, 965 -1.0/360.0, 966 1.0/1260.0, 967 -1.0/1680.0, 968 1.0/1188.0, 969 -691.0/360360.0, 970 1.0/156.0, 971 -3617.0/122400.0 972 }; 973 NV z = 1.0 / (x * x); 974 NV sum = c[7]; 975 static const NV half_log_of_two_pi = 976 0.91893853320467274178032973640562; 977 NV series; 978 int i; 979 for (i = 6; i >= 0; i--) { 980 sum *= z; 981 sum += c[i]; 982 } 983 series = sum / x; 984 return (x - 0.5) * Perl_log(x) - x + half_log_of_two_pi + series; 985 } 986 } 987 #endif 988 989 #ifndef c99_log1p 990 static NV my_log1p(NV x) 991 { 992 /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain. 993 * Taylor series, the first four terms (the last term quartic). */ 994 #ifdef NV_NAN 995 if (x < -1.0) 996 return NV_NAN; 997 #endif 998 #ifdef NV_INF 999 if (x == -1.0) 1000 return -NV_INF; 1001 #endif 1002 if (PERL_ABS(x) > 1e-4) 1003 return Perl_log(1.0 + x); 1004 else 1005 /* Probably not enough for long doubles. */ 1006 return x * (1.0 + x * (-1/2.0 + x * (1/3.0 - x/4.0))); 1007 } 1008 # define c99_log1p my_log1p 1009 #endif 1010 1011 #ifndef c99_log2 1012 static NV my_log2(NV x) 1013 { 1014 return Perl_log(x) * M_LOG2E; 1015 } 1016 # define c99_log2 my_log2 1017 #endif 1018 1019 /* XXX nextafter */ 1020 1021 /* XXX nexttoward */ 1022 1023 static int my_fegetround() 1024 { 1025 #ifdef HAS_FEGETROUND 1026 return fegetround(); 1027 #elif defined(HAS_FPGETROUND) 1028 switch (fpgetround()) { 1029 case FP_RN: return FE_TONEAREST; 1030 case FP_RZ: return FE_TOWARDZERO; 1031 case FP_RM: return FE_DOWNWARD; 1032 case FP_RP: return FE_UPWARD; 1033 default: return -1; 1034 } 1035 #elif defined(FLT_ROUNDS) 1036 switch (FLT_ROUNDS) { 1037 case 0: return FE_TOWARDZERO; 1038 case 1: return FE_TONEAREST; 1039 case 2: return FE_UPWARD; 1040 case 3: return FE_DOWNWARD; 1041 default: return -1; 1042 } 1043 #elif defined(__osf__) /* Tru64 */ 1044 switch (read_rnd()) { 1045 case FP_RND_RN: return FE_TONEAREST; 1046 case FP_RND_RZ: return FE_TOWARDZERO; 1047 case FP_RND_RM: return FE_DOWNWARD; 1048 case FP_RND_RP: return FE_UPWARD; 1049 default: return -1; 1050 } 1051 #else 1052 return -1; 1053 #endif 1054 } 1055 1056 /* Toward closest integer. */ 1057 #define MY_ROUND_NEAREST(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x) - 0.5))) 1058 1059 /* Toward zero. */ 1060 #define MY_ROUND_TRUNC(x) ((NV)((IV)(x))) 1061 1062 /* Toward minus infinity. */ 1063 #define MY_ROUND_DOWN(x) ((NV)((IV)((x) >= 0.0 ? (x) : (x) - 0.5))) 1064 1065 /* Toward plus infinity. */ 1066 #define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x)))) 1067 1068 #if (!defined(c99_nearbyint) || !defined(c99_lrint)) && defined(FE_TONEAREST) 1069 static NV my_rint(NV x) 1070 { 1071 #ifdef FE_TONEAREST 1072 switch (my_fegetround()) { 1073 case FE_TONEAREST: return MY_ROUND_NEAREST(x); 1074 case FE_TOWARDZERO: return MY_ROUND_TRUNC(x); 1075 case FE_DOWNWARD: return MY_ROUND_DOWN(x); 1076 case FE_UPWARD: return MY_ROUND_UP(x); 1077 default: break; 1078 } 1079 #elif defined(HAS_FPGETROUND) 1080 switch (fpgetround()) { 1081 case FP_RN: return MY_ROUND_NEAREST(x); 1082 case FP_RZ: return MY_ROUND_TRUNC(x); 1083 case FP_RM: return MY_ROUND_DOWN(x); 1084 case FE_RP: return MY_ROUND_UP(x); 1085 default: break; 1086 } 1087 #endif 1088 not_here("rint"); 1089 } 1090 #endif 1091 1092 /* XXX nearbyint() and rint() are not really identical -- but the difference 1093 * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point 1094 * exceptions, while rint() is defined to MAYBE raise them. At the moment 1095 * Perl is blissfully unaware of such fine detail of floating point. */ 1096 #ifndef c99_nearbyint 1097 # ifdef FE_TONEAREST 1098 # define c99_nearbyrint my_rint 1099 # endif 1100 #endif 1101 1102 #ifndef c99_lrint 1103 # ifdef FE_TONEAREST 1104 static IV my_lrint(NV x) 1105 { 1106 return (IV)my_rint(x); 1107 } 1108 # define c99_lrint my_lrint 1109 # endif 1110 #endif 1111 1112 #ifndef c99_lround 1113 static IV my_lround(NV x) 1114 { 1115 return (IV)MY_ROUND_NEAREST(x); 1116 } 1117 # define c99_lround my_lround 1118 #endif 1119 1120 /* XXX remainder */ 1121 1122 /* XXX remquo */ 1123 1124 #ifndef c99_rint 1125 # ifdef FE_TONEAREST 1126 # define c99_rint my_rint 1127 # endif 1128 #endif 1129 1130 #ifndef c99_round 1131 static NV my_round(NV x) 1132 { 1133 return MY_ROUND_NEAREST(x); 1134 } 1135 # define c99_round my_round 1136 #endif 1137 1138 #ifndef c99_scalbn 1139 # if defined(Perl_ldexp) && FLT_RADIX == 2 1140 static NV my_scalbn(NV x, int y) 1141 { 1142 return Perl_ldexp(x, y); 1143 } 1144 # define c99_scalbn my_scalbn 1145 # endif 1146 #endif 1147 1148 /* XXX sinh (though c89) */ 1149 1150 /* tgamma -- see lgamma */ 1151 1152 /* XXX tanh (though c89) */ 1153 1154 #ifndef c99_trunc 1155 static NV my_trunc(NV x) 1156 { 1157 return MY_ROUND_TRUNC(x); 1158 } 1159 # define c99_trunc my_trunc 1160 #endif 1161 1162 #ifdef NV_NAN 1163 1164 #undef NV_PAYLOAD_DEBUG 1165 1166 /* NOTE: the NaN payload API implementation is hand-rolled, since the 1167 * APIs are only proposed ones as of June 2015, so very few, if any, 1168 * platforms have implementations yet, so HAS_SETPAYLOAD and such are 1169 * unlikely to be helpful. 1170 * 1171 * XXX - if the core numification wants to actually generate 1172 * the nan payload in "nan(123)", and maybe "nans(456)", for 1173 * signaling payload", this needs to be moved to e.g. numeric.c 1174 * (look for grok_infnan) 1175 * 1176 * Conversely, if the core stringification wants the nan payload 1177 * and/or the nan quiet/signaling distinction, S_getpayload() 1178 * from this file needs to be moved, to e.g. sv.c (look for S_infnan_2pv), 1179 * and the (trivial) functionality of issignaling() copied 1180 * (for generating "NaNS", or maybe even "NaNQ") -- or maybe there 1181 * are too many formatting parameters for simple stringification? 1182 */ 1183 1184 /* While it might make sense for the payload to be UV or IV, 1185 * to avoid conversion loss, the proposed ISO interfaces use 1186 * a floating point input, which is then truncated to integer, 1187 * and only the integer part being used. This is workable, 1188 * except for: (1) the conversion loss (2) suboptimal for 1189 * 32-bit integer platforms. A workaround API for (2) and 1190 * in general for bit-honesty would be an array of integers 1191 * as the payload... but the proposed C API does nothing of 1192 * the kind. */ 1193 #if NVSIZE == UVSIZE 1194 # define NV_PAYLOAD_TYPE UV 1195 #else 1196 # define NV_PAYLOAD_TYPE NV 1197 #endif 1198 1199 #if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE) 1200 # define NV_PAYLOAD_SIZEOF_ASSERT(a) \ 1201 STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2) 1202 #else 1203 # define NV_PAYLOAD_SIZEOF_ASSERT(a) \ 1204 STATIC_ASSERT_STMT(sizeof(a) == NVSIZE) 1205 #endif 1206 1207 static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) 1208 { 1209 dTHX; 1210 static const U8 m[] = { NV_NAN_PAYLOAD_MASK }; 1211 static const U8 p[] = { NV_NAN_PAYLOAD_PERM }; 1212 UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 }; 1213 int i; 1214 NV_PAYLOAD_SIZEOF_ASSERT(m); 1215 NV_PAYLOAD_SIZEOF_ASSERT(p); 1216 *nvp = NV_NAN; 1217 /* Divide the input into the array in "base unsigned integer" in 1218 * little-endian order. Note that the integer might be smaller than 1219 * an NV (if UV is U32, for example). */ 1220 #if NVSIZE == UVSIZE 1221 a[0] = payload; /* The trivial case. */ 1222 #else 1223 { 1224 NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */ 1225 #ifdef NV_PAYLOAD_DEBUG 1226 Perl_warn(aTHX_ "t1 = %" NVgf " (payload %" NVgf ")\n", t1, payload); 1227 #endif 1228 if (t1 <= UV_MAX) { 1229 a[0] = (UV)t1; /* Fast path, also avoids rounding errors (right?) */ 1230 } else { 1231 /* UVSIZE < NVSIZE or payload > UV_MAX. 1232 * 1233 * This may happen for example if: 1234 * (1) UVSIZE == 32 and common 64-bit double NV 1235 * (32-bit system not using -Duse64bitint) 1236 * (2) UVSIZE == 64 and the x86-style 80-bit long double NV 1237 * (note that here the room for payload is actually the 64 bits) 1238 * (3) UVSIZE == 64 and the 128-bit IEEE 764 quadruple NV 1239 * (112 bits in mantissa, 111 bits room for payload) 1240 * 1241 * NOTE: this is very sensitive to correctly functioning 1242 * fmod()/fmodl(), and correct casting of big-unsigned-integer to NV. 1243 * If these don't work right, especially the low order bits 1244 * are in danger. For example Solaris and AIX seem to have issues 1245 * here, especially if using 32-bit UVs. */ 1246 NV t2; 1247 for (i = 0, t2 = t1; i < (int)C_ARRAY_LENGTH(a); i++) { 1248 a[i] = (UV)Perl_fmod(t2, (NV)UV_MAX); 1249 t2 = Perl_floor(t2 / (NV)UV_MAX); 1250 } 1251 } 1252 } 1253 #endif 1254 #ifdef NV_PAYLOAD_DEBUG 1255 for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { 1256 Perl_warn(aTHX_ "a[%d] = 0x%" UVxf "\n", i, a[i]); 1257 } 1258 #endif 1259 for (i = 0; i < (int)sizeof(p); i++) { 1260 if (m[i] && p[i] < sizeof(p)) { 1261 U8 s = (p[i] % UVSIZE) << 3; 1262 UV u = a[p[i] / UVSIZE] & ((UV)0xFF << s); 1263 U8 b = (U8)((u >> s) & m[i]); 1264 ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */ 1265 ((U8 *)(nvp))[i] |= b; 1266 #ifdef NV_PAYLOAD_DEBUG 1267 Perl_warn(aTHX_ 1268 "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08" 1269 UVxf ")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u); 1270 #endif 1271 a[p[i] / UVSIZE] &= ~u; 1272 } 1273 } 1274 if (signaling) { 1275 NV_NAN_SET_SIGNALING(nvp); 1276 } 1277 #ifdef USE_LONG_DOUBLE 1278 # if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4 1279 # if LONG_DOUBLESIZE > 10 1280 memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */ 1281 # endif 1282 # endif 1283 #endif 1284 for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { 1285 if (a[i]) { 1286 Perl_warn(aTHX_ "payload lost bits (%" UVxf ")", a[i]); 1287 break; 1288 } 1289 } 1290 #ifdef NV_PAYLOAD_DEBUG 1291 for (i = 0; i < NVSIZE; i++) { 1292 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]); 1293 } 1294 PerlIO_printf(Perl_debug_log, "\n"); 1295 #endif 1296 } 1297 1298 static NV_PAYLOAD_TYPE S_getpayload(NV nv) 1299 { 1300 dTHX; 1301 static const U8 m[] = { NV_NAN_PAYLOAD_MASK }; 1302 static const U8 p[] = { NV_NAN_PAYLOAD_PERM }; 1303 UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 }; 1304 int i; 1305 NV payload; 1306 NV_PAYLOAD_SIZEOF_ASSERT(m); 1307 NV_PAYLOAD_SIZEOF_ASSERT(p); 1308 payload = 0; 1309 for (i = 0; i < (int)sizeof(p); i++) { 1310 if (m[i] && p[i] < NVSIZE) { 1311 U8 s = (p[i] % UVSIZE) << 3; 1312 a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s; 1313 } 1314 } 1315 for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) { 1316 #ifdef NV_PAYLOAD_DEBUG 1317 Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]); 1318 #endif 1319 payload *= UV_MAX; 1320 payload += a[i]; 1321 } 1322 #ifdef NV_PAYLOAD_DEBUG 1323 for (i = 0; i < NVSIZE; i++) { 1324 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]); 1325 } 1326 PerlIO_printf(Perl_debug_log, "\n"); 1327 #endif 1328 return payload; 1329 } 1330 1331 #endif /* #ifdef NV_NAN */ 1332 1333 /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to 1334 metaconfig for future extension writers. We don't use them in POSIX. 1335 (This is really sneaky :-) --AD 1336 */ 1337 #if defined(I_TERMIOS) 1338 #include <termios.h> 1339 #endif 1340 #include <stdlib.h> 1341 #ifndef __ultrix__ 1342 #include <string.h> 1343 #endif 1344 #include <sys/stat.h> 1345 #include <sys/types.h> 1346 #include <time.h> 1347 #ifdef I_UNISTD 1348 #include <unistd.h> 1349 #endif 1350 #include <fcntl.h> 1351 1352 #ifdef HAS_TZNAME 1353 # if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__) 1354 extern char *tzname[]; 1355 # endif 1356 #else 1357 #if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname)) 1358 char *tzname[] = { "" , "" }; 1359 #endif 1360 #endif 1361 1362 #if defined(__VMS) && !defined(__POSIX_SOURCE) 1363 1364 # include <utsname.h> 1365 1366 # undef mkfifo 1367 # define mkfifo(a,b) (not_here("mkfifo"),-1) 1368 1369 /* The POSIX notion of ttyname() is better served by getname() under VMS */ 1370 static char ttnambuf[64]; 1371 # define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL) 1372 1373 #else 1374 #if defined (__CYGWIN__) 1375 # define tzname _tzname 1376 #endif 1377 #if defined (WIN32) || defined (NETWARE) 1378 # undef mkfifo 1379 # define mkfifo(a,b) not_here("mkfifo") 1380 # define ttyname(a) (char*)not_here("ttyname") 1381 # define sigset_t long 1382 # define pid_t long 1383 # ifdef _MSC_VER 1384 # define mode_t short 1385 # endif 1386 # ifdef __MINGW32__ 1387 # define mode_t short 1388 # ifndef tzset 1389 # define tzset() not_here("tzset") 1390 # endif 1391 # ifndef _POSIX_OPEN_MAX 1392 # define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */ 1393 # endif 1394 # endif 1395 # define sigaction(a,b,c) not_here("sigaction") 1396 # define sigpending(a) not_here("sigpending") 1397 # define sigprocmask(a,b,c) not_here("sigprocmask") 1398 # define sigsuspend(a) not_here("sigsuspend") 1399 # define sigemptyset(a) not_here("sigemptyset") 1400 # define sigaddset(a,b) not_here("sigaddset") 1401 # define sigdelset(a,b) not_here("sigdelset") 1402 # define sigfillset(a) not_here("sigfillset") 1403 # define sigismember(a,b) not_here("sigismember") 1404 #ifndef NETWARE 1405 # undef setuid 1406 # undef setgid 1407 # define setuid(a) not_here("setuid") 1408 # define setgid(a) not_here("setgid") 1409 #endif /* NETWARE */ 1410 #ifndef USE_LONG_DOUBLE 1411 # define strtold(s1,s2) not_here("strtold") 1412 #endif /* USE_LONG_DOUBLE */ 1413 #else 1414 1415 # ifndef HAS_MKFIFO 1416 # if defined(OS2) || defined(__amigaos4__) 1417 # define mkfifo(a,b) not_here("mkfifo") 1418 # else /* !( defined OS2 ) */ 1419 # ifndef mkfifo 1420 # define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) 1421 # endif 1422 # endif 1423 # endif /* !HAS_MKFIFO */ 1424 1425 # ifdef I_GRP 1426 # include <grp.h> 1427 # endif 1428 # include <sys/times.h> 1429 # ifdef HAS_UNAME 1430 # include <sys/utsname.h> 1431 # endif 1432 # ifndef __amigaos4__ 1433 # include <sys/wait.h> 1434 # endif 1435 # ifdef I_UTIME 1436 # include <utime.h> 1437 # endif 1438 #endif /* WIN32 || NETWARE */ 1439 #endif /* __VMS */ 1440 1441 typedef int SysRet; 1442 typedef long SysRetLong; 1443 typedef sigset_t* POSIX__SigSet; 1444 typedef HV* POSIX__SigAction; 1445 typedef int POSIX__SigNo; 1446 typedef int POSIX__Fd; 1447 #ifdef I_TERMIOS 1448 typedef struct termios* POSIX__Termios; 1449 #else /* Define termios types to int, and call not_here for the functions.*/ 1450 #define POSIX__Termios int 1451 #define speed_t int 1452 #define tcflag_t int 1453 #define cc_t int 1454 #define cfgetispeed(x) not_here("cfgetispeed") 1455 #define cfgetospeed(x) not_here("cfgetospeed") 1456 #define tcdrain(x) not_here("tcdrain") 1457 #define tcflush(x,y) not_here("tcflush") 1458 #define tcsendbreak(x,y) not_here("tcsendbreak") 1459 #define cfsetispeed(x,y) not_here("cfsetispeed") 1460 #define cfsetospeed(x,y) not_here("cfsetospeed") 1461 #define ctermid(x) (char *) not_here("ctermid") 1462 #define tcflow(x,y) not_here("tcflow") 1463 #define tcgetattr(x,y) not_here("tcgetattr") 1464 #define tcsetattr(x,y,z) not_here("tcsetattr") 1465 #endif 1466 1467 /* Possibly needed prototypes */ 1468 #ifndef WIN32 1469 START_EXTERN_C 1470 double strtod (const char *, char **); 1471 long strtol (const char *, char **, int); 1472 unsigned long strtoul (const char *, char **, int); 1473 #ifdef HAS_STRTOLD 1474 long double strtold (const char *, char **); 1475 #endif 1476 END_EXTERN_C 1477 #endif 1478 1479 #ifndef HAS_DIFFTIME 1480 #ifndef difftime 1481 #define difftime(a,b) not_here("difftime") 1482 #endif 1483 #endif 1484 #ifndef HAS_FPATHCONF 1485 #define fpathconf(f,n) (SysRetLong) not_here("fpathconf") 1486 #endif 1487 #ifndef HAS_MKTIME 1488 #define mktime(a) not_here("mktime") 1489 #endif 1490 #ifndef HAS_NICE 1491 #define nice(a) not_here("nice") 1492 #endif 1493 #ifndef HAS_PATHCONF 1494 #define pathconf(f,n) (SysRetLong) not_here("pathconf") 1495 #endif 1496 #ifndef HAS_SYSCONF 1497 #define sysconf(n) (SysRetLong) not_here("sysconf") 1498 #endif 1499 #ifndef HAS_READLINK 1500 #define readlink(a,b,c) not_here("readlink") 1501 #endif 1502 #ifndef HAS_SETPGID 1503 #define setpgid(a,b) not_here("setpgid") 1504 #endif 1505 #ifndef HAS_SETSID 1506 #define setsid() not_here("setsid") 1507 #endif 1508 #ifndef HAS_STRCOLL 1509 #define strcoll(s1,s2) not_here("strcoll") 1510 #endif 1511 #ifndef HAS_STRTOD 1512 #define strtod(s1,s2) not_here("strtod") 1513 #endif 1514 #ifndef HAS_STRTOLD 1515 #define strtold(s1,s2) not_here("strtold") 1516 #endif 1517 #ifndef HAS_STRTOL 1518 #define strtol(s1,s2,b) not_here("strtol") 1519 #endif 1520 #ifndef HAS_STRTOUL 1521 #define strtoul(s1,s2,b) not_here("strtoul") 1522 #endif 1523 #ifndef HAS_STRXFRM 1524 #define strxfrm(s1,s2,n) not_here("strxfrm") 1525 #endif 1526 #ifndef HAS_TCGETPGRP 1527 #define tcgetpgrp(a) not_here("tcgetpgrp") 1528 #endif 1529 #ifndef HAS_TCSETPGRP 1530 #define tcsetpgrp(a,b) not_here("tcsetpgrp") 1531 #endif 1532 #ifndef HAS_TIMES 1533 #ifndef NETWARE 1534 #define times(a) not_here("times") 1535 #endif /* NETWARE */ 1536 #endif 1537 #ifndef HAS_UNAME 1538 #define uname(a) not_here("uname") 1539 #endif 1540 #ifndef HAS_WAITPID 1541 #define waitpid(a,b,c) not_here("waitpid") 1542 #endif 1543 1544 #ifndef HAS_MBLEN 1545 #ifndef mblen 1546 #define mblen(a,b) not_here("mblen") 1547 #endif 1548 #endif 1549 #ifndef HAS_MBSTOWCS 1550 #define mbstowcs(s, pwcs, n) not_here("mbstowcs") 1551 #endif 1552 #ifndef HAS_MBTOWC 1553 #define mbtowc(pwc, s, n) not_here("mbtowc") 1554 #endif 1555 #ifndef HAS_WCSTOMBS 1556 #define wcstombs(s, pwcs, n) not_here("wcstombs") 1557 #endif 1558 #ifndef HAS_WCTOMB 1559 #define wctomb(s, wchar) not_here("wcstombs") 1560 #endif 1561 #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB) 1562 /* If we don't have these functions, then we wouldn't have gotten a typedef 1563 for wchar_t, the wide character type. Defining wchar_t allows the 1564 functions referencing it to compile. Its actual type is then meaningless, 1565 since without the above functions, all sections using it end up calling 1566 not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */ 1567 #ifndef wchar_t 1568 #define wchar_t char 1569 #endif 1570 #endif 1571 1572 #ifndef HAS_LOCALECONV 1573 # define localeconv() not_here("localeconv") 1574 #else 1575 struct lconv_offset { 1576 const char *name; 1577 size_t offset; 1578 }; 1579 1580 static const struct lconv_offset lconv_strings[] = { 1581 #ifdef USE_LOCALE_NUMERIC 1582 {"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)}, 1583 {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)}, 1584 # ifndef NO_LOCALECONV_GROUPING 1585 {"grouping", STRUCT_OFFSET(struct lconv, grouping)}, 1586 # endif 1587 #endif 1588 #ifdef USE_LOCALE_MONETARY 1589 {"int_curr_symbol", STRUCT_OFFSET(struct lconv, int_curr_symbol)}, 1590 {"currency_symbol", STRUCT_OFFSET(struct lconv, currency_symbol)}, 1591 {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)}, 1592 # ifndef NO_LOCALECONV_MON_THOUSANDS_SEP 1593 {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)}, 1594 # endif 1595 # ifndef NO_LOCALECONV_MON_GROUPING 1596 {"mon_grouping", STRUCT_OFFSET(struct lconv, mon_grouping)}, 1597 # endif 1598 {"positive_sign", STRUCT_OFFSET(struct lconv, positive_sign)}, 1599 {"negative_sign", STRUCT_OFFSET(struct lconv, negative_sign)}, 1600 #endif 1601 {NULL, 0} 1602 }; 1603 1604 #ifdef USE_LOCALE_NUMERIC 1605 1606 /* The Linux man pages say these are the field names for the structure 1607 * components that are LC_NUMERIC; the rest being LC_MONETARY */ 1608 # define isLC_NUMERIC_STRING(name) ( strEQ(name, "decimal_point") \ 1609 || strEQ(name, "thousands_sep") \ 1610 \ 1611 /* There should be no harm done \ 1612 * checking for this, even if \ 1613 * NO_LOCALECONV_GROUPING */ \ 1614 || strEQ(name, "grouping")) 1615 #else 1616 # define isLC_NUMERIC_STRING(name) (0) 1617 #endif 1618 1619 static const struct lconv_offset lconv_integers[] = { 1620 #ifdef USE_LOCALE_MONETARY 1621 {"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)}, 1622 {"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)}, 1623 {"p_cs_precedes", STRUCT_OFFSET(struct lconv, p_cs_precedes)}, 1624 {"p_sep_by_space", STRUCT_OFFSET(struct lconv, p_sep_by_space)}, 1625 {"n_cs_precedes", STRUCT_OFFSET(struct lconv, n_cs_precedes)}, 1626 {"n_sep_by_space", STRUCT_OFFSET(struct lconv, n_sep_by_space)}, 1627 {"p_sign_posn", STRUCT_OFFSET(struct lconv, p_sign_posn)}, 1628 {"n_sign_posn", STRUCT_OFFSET(struct lconv, n_sign_posn)}, 1629 #ifdef HAS_LC_MONETARY_2008 1630 {"int_p_cs_precedes", STRUCT_OFFSET(struct lconv, int_p_cs_precedes)}, 1631 {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)}, 1632 {"int_n_cs_precedes", STRUCT_OFFSET(struct lconv, int_n_cs_precedes)}, 1633 {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)}, 1634 {"int_p_sign_posn", STRUCT_OFFSET(struct lconv, int_p_sign_posn)}, 1635 {"int_n_sign_posn", STRUCT_OFFSET(struct lconv, int_n_sign_posn)}, 1636 #endif 1637 #endif 1638 {NULL, 0} 1639 }; 1640 1641 #endif /* HAS_LOCALECONV */ 1642 1643 #ifdef HAS_LONG_DOUBLE 1644 # if LONG_DOUBLESIZE > NVSIZE 1645 # undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */ 1646 # endif 1647 #endif 1648 1649 #ifndef HAS_LONG_DOUBLE 1650 #ifdef LDBL_MAX 1651 #undef LDBL_MAX 1652 #endif 1653 #ifdef LDBL_MIN 1654 #undef LDBL_MIN 1655 #endif 1656 #ifdef LDBL_EPSILON 1657 #undef LDBL_EPSILON 1658 #endif 1659 #endif 1660 1661 /* Background: in most systems the low byte of the wait status 1662 * is the signal (the lowest 7 bits) and the coredump flag is 1663 * the eight bit, and the second lowest byte is the exit status. 1664 * BeOS bucks the trend and has the bytes in different order. 1665 * See beos/beos.c for how the reality is bent even in BeOS 1666 * to follow the traditional. However, to make the POSIX 1667 * wait W*() macros to work in BeOS, we need to unbend the 1668 * reality back in place. --jhi */ 1669 /* In actual fact the code below is to blame here. Perl has an internal 1670 * representation of the exit status ($?), which it re-composes from the 1671 * OS's representation using the W*() POSIX macros. The code below 1672 * incorrectly uses the W*() macros on the internal representation, 1673 * which fails for OSs that have a different representation (namely BeOS 1674 * and Haiku). WMUNGE() is a hack that converts the internal 1675 * representation into the OS specific one, so that the W*() macros work 1676 * as expected. The better solution would be not to use the W*() macros 1677 * in the first place, though. -- Ingo Weinhold 1678 */ 1679 #if defined(__HAIKU__) 1680 # define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8) 1681 #else 1682 # define WMUNGE(x) (x) 1683 #endif 1684 1685 static int 1686 not_here(const char *s) 1687 { 1688 croak("POSIX::%s not implemented on this architecture", s); 1689 return -1; 1690 } 1691 1692 #include "const-c.inc" 1693 1694 static void 1695 restore_sigmask(pTHX_ SV *osset_sv) 1696 { 1697 /* Fortunately, restoring the signal mask can't fail, because 1698 * there's nothing we can do about it if it does -- we're not 1699 * supposed to return -1 from sigaction unless the disposition 1700 * was unaffected. 1701 */ 1702 #if !(defined(__amigaos4__) && defined(__NEWLIB__)) 1703 sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv ); 1704 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); 1705 #endif 1706 } 1707 1708 static void * 1709 allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) { 1710 SV *const t = newSVrv(rv, packname); 1711 void *const p = sv_grow(t, size + 1); 1712 1713 /* Ensure at least one use of not_here() to avoid "defined but not 1714 * used" warning. This is not at all related to allocate_struct(); I 1715 * just needed somewhere to dump it - DAPM */ 1716 if (0) { not_here(""); } 1717 1718 SvCUR_set(t, size); 1719 SvPOK_on(t); 1720 return p; 1721 } 1722 1723 #ifdef WIN32 1724 1725 /* 1726 * (1) The CRT maintains its own copy of the environment, separate from 1727 * the Win32API copy. 1728 * 1729 * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this 1730 * copy, and then calls SetEnvironmentVariableA() to update the Win32API 1731 * copy. 1732 * 1733 * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and 1734 * SetEnvironmentVariableA() directly, bypassing the CRT copy of the 1735 * environment. 1736 * 1737 * (4) The CRT strftime() "%Z" implementation calls __tzset(). That 1738 * calls CRT tzset(), but only the first time it is called, and in turn 1739 * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT 1740 * local copy of the environment and hence gets the original setting as 1741 * perl never updates the CRT copy when assigning to $ENV{TZ}. 1742 * 1743 * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT 1744 * putenv() to update the CRT copy of the environment (if it is different) 1745 * whenever we're about to call tzset(). 1746 * 1747 * In addition to all that, when perl is built with PERL_IMPLICIT_SYS 1748 * defined: 1749 * 1750 * (a) Each interpreter has its own copy of the environment inside the 1751 * perlhost structure. That allows applications that host multiple 1752 * independent Perl interpreters to isolate environment changes from 1753 * each other. (This is similar to how the perlhost mechanism keeps a 1754 * separate working directory for each Perl interpreter, so that calling 1755 * chdir() will not affect other interpreters.) 1756 * 1757 * (b) Only the first Perl interpreter instantiated within a process will 1758 * "write through" environment changes to the process environment. 1759 * 1760 * (c) Even the primary Perl interpreter won't update the CRT copy of the 1761 * the environment, only the Win32API copy (it calls win32_putenv()). 1762 * 1763 * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes 1764 * sense to only update the process environment when inside the main 1765 * interpreter, but we don't have access to CPerlHost's m_bTopLevel member 1766 * from here so we'll just have to check PL_curinterp instead. 1767 * 1768 * Therefore, we can simply #undef getenv() and putenv() so that those names 1769 * always refer to the CRT functions, and explicitly call win32_getenv() to 1770 * access perl's %ENV. 1771 * 1772 * We also #undef malloc() and free() to be sure we are using the CRT 1773 * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls 1774 * into VMem::Malloc() and VMem::Free() and all allocations will be freed 1775 * when the Perl interpreter is being destroyed so we'd end up with a pointer 1776 * into deallocated memory in environ[] if a program embedding a Perl 1777 * interpreter continues to operate even after the main Perl interpreter has 1778 * been destroyed. 1779 * 1780 * Note that we don't free() the malloc()ed memory unless and until we call 1781 * malloc() again ourselves because the CRT putenv() function simply puts its 1782 * pointer argument into the environ[] array (it doesn't make a copy of it) 1783 * so this memory must otherwise be leaked. 1784 */ 1785 1786 #undef getenv 1787 #undef putenv 1788 #undef malloc 1789 #undef free 1790 1791 static void 1792 fix_win32_tzenv(void) 1793 { 1794 static char* oldenv = NULL; 1795 char* newenv; 1796 const char* perl_tz_env = win32_getenv("TZ"); 1797 const char* crt_tz_env = getenv("TZ"); 1798 if (perl_tz_env == NULL) 1799 perl_tz_env = ""; 1800 if (crt_tz_env == NULL) 1801 crt_tz_env = ""; 1802 if (strNE(perl_tz_env, crt_tz_env)) { 1803 newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char)); 1804 if (newenv != NULL) { 1805 sprintf(newenv, "TZ=%s", perl_tz_env); 1806 putenv(newenv); 1807 if (oldenv != NULL) 1808 free(oldenv); 1809 oldenv = newenv; 1810 } 1811 } 1812 } 1813 1814 #endif 1815 1816 /* 1817 * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32. 1818 * This code is duplicated in the Time-Piece module, so any changes made here 1819 * should be made there too. 1820 */ 1821 static void 1822 my_tzset(pTHX) 1823 { 1824 #ifdef WIN32 1825 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 1826 if (PL_curinterp == aTHX) 1827 #endif 1828 fix_win32_tzenv(); 1829 #endif 1830 tzset(); 1831 } 1832 1833 MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig 1834 1835 void 1836 new(packname = "POSIX::SigSet", ...) 1837 const char * packname 1838 CODE: 1839 { 1840 int i; 1841 sigset_t *const s 1842 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()), 1843 sizeof(sigset_t), 1844 packname); 1845 sigemptyset(s); 1846 for (i = 1; i < items; i++) 1847 sigaddset(s, SvIV(ST(i))); 1848 XSRETURN(1); 1849 } 1850 1851 SysRet 1852 addset(sigset, sig) 1853 POSIX::SigSet sigset 1854 POSIX::SigNo sig 1855 ALIAS: 1856 delset = 1 1857 CODE: 1858 RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig); 1859 OUTPUT: 1860 RETVAL 1861 1862 SysRet 1863 emptyset(sigset) 1864 POSIX::SigSet sigset 1865 ALIAS: 1866 fillset = 1 1867 CODE: 1868 RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset); 1869 OUTPUT: 1870 RETVAL 1871 1872 int 1873 sigismember(sigset, sig) 1874 POSIX::SigSet sigset 1875 POSIX::SigNo sig 1876 1877 MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf 1878 1879 void 1880 new(packname = "POSIX::Termios", ...) 1881 const char * packname 1882 CODE: 1883 { 1884 #ifdef I_TERMIOS 1885 void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()), 1886 sizeof(struct termios), packname); 1887 /* The previous implementation stored a pointer to an uninitialised 1888 struct termios. Seems safer to initialise it, particularly as 1889 this implementation exposes the struct to prying from perl-space. 1890 */ 1891 memset(p, 0, 1 + sizeof(struct termios)); 1892 XSRETURN(1); 1893 #else 1894 not_here("termios"); 1895 #endif 1896 } 1897 1898 SysRet 1899 getattr(termios_ref, fd = 0) 1900 POSIX::Termios termios_ref 1901 POSIX::Fd fd 1902 CODE: 1903 RETVAL = tcgetattr(fd, termios_ref); 1904 OUTPUT: 1905 RETVAL 1906 1907 # If we define TCSANOW here then both a found and not found constant sub 1908 # are created causing a Constant subroutine TCSANOW redefined warning 1909 1910 #ifndef TCSANOW 1911 # define DEF_SETATTR_ACTION 0 1912 #else 1913 # define DEF_SETATTR_ACTION TCSANOW 1914 #endif 1915 SysRet 1916 setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION) 1917 POSIX::Termios termios_ref 1918 POSIX::Fd fd 1919 int optional_actions 1920 CODE: 1921 /* The second argument to the call is mandatory, but we'd like to give 1922 it a useful default. 0 isn't valid on all operating systems - on 1923 Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same 1924 values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */ 1925 if (optional_actions < 0) { 1926 SETERRNO(EINVAL, LIB_INVARG); 1927 RETVAL = -1; 1928 } else { 1929 RETVAL = tcsetattr(fd, optional_actions, termios_ref); 1930 } 1931 OUTPUT: 1932 RETVAL 1933 1934 speed_t 1935 getispeed(termios_ref) 1936 POSIX::Termios termios_ref 1937 ALIAS: 1938 getospeed = 1 1939 CODE: 1940 RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref); 1941 OUTPUT: 1942 RETVAL 1943 1944 tcflag_t 1945 getiflag(termios_ref) 1946 POSIX::Termios termios_ref 1947 ALIAS: 1948 getoflag = 1 1949 getcflag = 2 1950 getlflag = 3 1951 CODE: 1952 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ 1953 switch(ix) { 1954 case 0: 1955 RETVAL = termios_ref->c_iflag; 1956 break; 1957 case 1: 1958 RETVAL = termios_ref->c_oflag; 1959 break; 1960 case 2: 1961 RETVAL = termios_ref->c_cflag; 1962 break; 1963 case 3: 1964 RETVAL = termios_ref->c_lflag; 1965 break; 1966 default: 1967 RETVAL = 0; /* silence compiler warning */ 1968 } 1969 #else 1970 not_here(GvNAME(CvGV(cv))); 1971 RETVAL = 0; 1972 #endif 1973 OUTPUT: 1974 RETVAL 1975 1976 cc_t 1977 getcc(termios_ref, ccix) 1978 POSIX::Termios termios_ref 1979 unsigned int ccix 1980 CODE: 1981 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ 1982 if (ccix >= NCCS) 1983 croak("Bad getcc subscript"); 1984 RETVAL = termios_ref->c_cc[ccix]; 1985 #else 1986 not_here("getcc"); 1987 RETVAL = 0; 1988 #endif 1989 OUTPUT: 1990 RETVAL 1991 1992 SysRet 1993 setispeed(termios_ref, speed) 1994 POSIX::Termios termios_ref 1995 speed_t speed 1996 ALIAS: 1997 setospeed = 1 1998 CODE: 1999 RETVAL = ix 2000 ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed); 2001 OUTPUT: 2002 RETVAL 2003 2004 void 2005 setiflag(termios_ref, flag) 2006 POSIX::Termios termios_ref 2007 tcflag_t flag 2008 ALIAS: 2009 setoflag = 1 2010 setcflag = 2 2011 setlflag = 3 2012 CODE: 2013 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ 2014 switch(ix) { 2015 case 0: 2016 termios_ref->c_iflag = flag; 2017 break; 2018 case 1: 2019 termios_ref->c_oflag = flag; 2020 break; 2021 case 2: 2022 termios_ref->c_cflag = flag; 2023 break; 2024 case 3: 2025 termios_ref->c_lflag = flag; 2026 break; 2027 } 2028 #else 2029 not_here(GvNAME(CvGV(cv))); 2030 #endif 2031 2032 void 2033 setcc(termios_ref, ccix, cc) 2034 POSIX::Termios termios_ref 2035 unsigned int ccix 2036 cc_t cc 2037 CODE: 2038 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ 2039 if (ccix >= NCCS) 2040 croak("Bad setcc subscript"); 2041 termios_ref->c_cc[ccix] = cc; 2042 #else 2043 not_here("setcc"); 2044 #endif 2045 2046 2047 MODULE = POSIX PACKAGE = POSIX 2048 2049 INCLUDE: const-xs.inc 2050 2051 int 2052 WEXITSTATUS(status) 2053 int status 2054 ALIAS: 2055 POSIX::WIFEXITED = 1 2056 POSIX::WIFSIGNALED = 2 2057 POSIX::WIFSTOPPED = 3 2058 POSIX::WSTOPSIG = 4 2059 POSIX::WTERMSIG = 5 2060 CODE: 2061 #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \ 2062 || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG) 2063 RETVAL = 0; /* Silence compilers that notice this, but don't realise 2064 that not_here() can't return. */ 2065 #endif 2066 switch(ix) { 2067 case 0: 2068 #ifdef WEXITSTATUS 2069 RETVAL = WEXITSTATUS(WMUNGE(status)); 2070 #else 2071 not_here("WEXITSTATUS"); 2072 #endif 2073 break; 2074 case 1: 2075 #ifdef WIFEXITED 2076 RETVAL = WIFEXITED(WMUNGE(status)); 2077 #else 2078 not_here("WIFEXITED"); 2079 #endif 2080 break; 2081 case 2: 2082 #ifdef WIFSIGNALED 2083 RETVAL = WIFSIGNALED(WMUNGE(status)); 2084 #else 2085 not_here("WIFSIGNALED"); 2086 #endif 2087 break; 2088 case 3: 2089 #ifdef WIFSTOPPED 2090 RETVAL = WIFSTOPPED(WMUNGE(status)); 2091 #else 2092 not_here("WIFSTOPPED"); 2093 #endif 2094 break; 2095 case 4: 2096 #ifdef WSTOPSIG 2097 RETVAL = WSTOPSIG(WMUNGE(status)); 2098 #else 2099 not_here("WSTOPSIG"); 2100 #endif 2101 break; 2102 case 5: 2103 #ifdef WTERMSIG 2104 RETVAL = WTERMSIG(WMUNGE(status)); 2105 #else 2106 not_here("WTERMSIG"); 2107 #endif 2108 break; 2109 default: 2110 croak("Illegal alias %d for POSIX::W*", (int)ix); 2111 } 2112 OUTPUT: 2113 RETVAL 2114 2115 SysRet 2116 open(filename, flags = O_RDONLY, mode = 0666) 2117 char * filename 2118 int flags 2119 Mode_t mode 2120 CODE: 2121 if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL)) 2122 TAINT_PROPER("open"); 2123 RETVAL = open(filename, flags, mode); 2124 OUTPUT: 2125 RETVAL 2126 2127 2128 HV * 2129 localeconv() 2130 CODE: 2131 #ifndef HAS_LOCALECONV 2132 localeconv(); /* A stub to call not_here(). */ 2133 #else 2134 struct lconv *lcbuf; 2135 # if defined(USE_ITHREADS) \ 2136 && defined(HAS_POSIX_2008_LOCALE) \ 2137 && defined(HAS_LOCALECONV_L) /* Prefer this thread-safe version */ 2138 bool do_free = FALSE; 2139 locale_t cur = NULL; 2140 # elif defined(TS_W32_BROKEN_LOCALECONV) 2141 const char * save_global; 2142 const char * save_thread; 2143 # endif 2144 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 2145 2146 /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but 2147 * LC_MONETARY is already in the correct locale */ 2148 # ifdef USE_LOCALE_MONETARY 2149 2150 const bool is_monetary_utf8 = _is_cur_LC_category_utf8(LC_MONETARY); 2151 # endif 2152 # ifdef USE_LOCALE_NUMERIC 2153 2154 bool is_numeric_utf8; 2155 2156 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); 2157 2158 is_numeric_utf8 = _is_cur_LC_category_utf8(LC_NUMERIC); 2159 # endif 2160 2161 RETVAL = newHV(); 2162 sv_2mortal((SV*)RETVAL); 2163 # if defined(USE_ITHREADS) \ 2164 && defined(HAS_POSIX_2008_LOCALE) \ 2165 && defined(HAS_LOCALECONV_L) \ 2166 && defined(HAS_DUPLOCALE) 2167 2168 cur = uselocale((locale_t) 0); 2169 if (cur == LC_GLOBAL_LOCALE) { 2170 cur = duplocale(LC_GLOBAL_LOCALE); 2171 do_free = TRUE; 2172 } 2173 2174 lcbuf = localeconv_l(cur); 2175 # else 2176 LOCALE_LOCK_V; /* Prevent interference with other threads using 2177 localeconv() */ 2178 # ifdef TS_W32_BROKEN_LOCALECONV 2179 /* This is a workaround for a Windows bug prior to VS 15, in which 2180 * localeconv only looks at the global locale. We toggle to the global 2181 * locale; populate the return; then toggle back. We have to use 2182 * LC_ALL instead of the individual ones because of another bug in 2183 * Windows */ 2184 2185 save_thread = savepv(Perl_setlocale(LC_NUMERIC, NULL)); 2186 2187 _configthreadlocale(_DISABLE_PER_THREAD_LOCALE); 2188 2189 save_global = savepv(Perl_setlocale(LC_ALL, NULL)); 2190 2191 Perl_setlocale(LC_ALL, save_thread); 2192 # endif 2193 lcbuf = localeconv(); 2194 # endif 2195 if (lcbuf) { 2196 const struct lconv_offset *strings = lconv_strings; 2197 const struct lconv_offset *integers = lconv_integers; 2198 const char *ptr = (const char *) lcbuf; 2199 2200 while (strings->name) { 2201 /* This string may be controlled by either LC_NUMERIC, or 2202 * LC_MONETARY */ 2203 const bool is_utf8_locale = 2204 # if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) 2205 (isLC_NUMERIC_STRING(strings->name)) 2206 ? is_numeric_utf8 2207 : is_monetary_utf8; 2208 # elif defined(USE_LOCALE_NUMERIC) 2209 is_numeric_utf8; 2210 # elif defined(USE_LOCALE_MONETARY) 2211 is_monetary_utf8; 2212 # else 2213 FALSE; 2214 # endif 2215 2216 const char *value = *((const char **)(ptr + strings->offset)); 2217 2218 if (value && *value) { 2219 const STRLEN value_len = strlen(value); 2220 2221 /* We mark it as UTF-8 if a utf8 locale and is valid and 2222 * variant under UTF-8 */ 2223 const bool is_utf8 = is_utf8_locale 2224 && is_utf8_non_invariant_string( 2225 (U8*) value, 2226 value_len); 2227 (void) hv_store(RETVAL, 2228 strings->name, 2229 strlen(strings->name), 2230 newSVpvn_utf8(value, value_len, is_utf8), 2231 0); 2232 } 2233 strings++; 2234 } 2235 2236 while (integers->name) { 2237 const char value = *((const char *)(ptr + integers->offset)); 2238 2239 if (value != CHAR_MAX) 2240 (void) hv_store(RETVAL, integers->name, 2241 strlen(integers->name), newSViv(value), 0); 2242 integers++; 2243 } 2244 } 2245 # if defined(USE_ITHREADS) \ 2246 && defined(HAS_POSIX_2008_LOCALE) \ 2247 && defined(HAS_LOCALECONV_L) 2248 if (do_free) { 2249 freelocale(cur); 2250 } 2251 # else 2252 # ifdef TS_W32_BROKEN_LOCALECONV 2253 Perl_setlocale(LC_ALL, save_global); 2254 2255 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE); 2256 2257 Perl_setlocale(LC_ALL, save_thread); 2258 2259 Safefree(save_global); 2260 Safefree(save_thread); 2261 # endif 2262 LOCALE_UNLOCK_V; 2263 # endif 2264 RESTORE_LC_NUMERIC(); 2265 #endif /* HAS_LOCALECONV */ 2266 OUTPUT: 2267 RETVAL 2268 2269 char * 2270 setlocale(category, locale = 0) 2271 int category 2272 const char * locale 2273 PREINIT: 2274 char * retval; 2275 CODE: 2276 retval = (char *) Perl_setlocale(category, locale); 2277 if (! retval) { 2278 XSRETURN_UNDEF; 2279 } 2280 2281 RETVAL = retval; 2282 OUTPUT: 2283 RETVAL 2284 2285 NV 2286 acos(x) 2287 NV x 2288 ALIAS: 2289 acosh = 1 2290 asin = 2 2291 asinh = 3 2292 atan = 4 2293 atanh = 5 2294 cbrt = 6 2295 ceil = 7 2296 cosh = 8 2297 erf = 9 2298 erfc = 10 2299 exp2 = 11 2300 expm1 = 12 2301 floor = 13 2302 j0 = 14 2303 j1 = 15 2304 lgamma = 16 2305 log10 = 17 2306 log1p = 18 2307 log2 = 19 2308 logb = 20 2309 nearbyint = 21 2310 rint = 22 2311 round = 23 2312 sinh = 24 2313 tan = 25 2314 tanh = 26 2315 tgamma = 27 2316 trunc = 28 2317 y0 = 29 2318 y1 = 30 2319 CODE: 2320 PERL_UNUSED_VAR(x); 2321 #ifdef NV_NAN 2322 RETVAL = NV_NAN; 2323 #else 2324 RETVAL = 0; 2325 #endif 2326 switch (ix) { 2327 case 0: 2328 RETVAL = Perl_acos(x); /* C89 math */ 2329 break; 2330 case 1: 2331 #ifdef c99_acosh 2332 RETVAL = c99_acosh(x); 2333 #else 2334 not_here("acosh"); 2335 #endif 2336 break; 2337 case 2: 2338 RETVAL = Perl_asin(x); /* C89 math */ 2339 break; 2340 case 3: 2341 #ifdef c99_asinh 2342 RETVAL = c99_asinh(x); 2343 #else 2344 not_here("asinh"); 2345 #endif 2346 break; 2347 case 4: 2348 RETVAL = Perl_atan(x); /* C89 math */ 2349 break; 2350 case 5: 2351 #ifdef c99_atanh 2352 RETVAL = c99_atanh(x); 2353 #else 2354 not_here("atanh"); 2355 #endif 2356 break; 2357 case 6: 2358 #ifdef c99_cbrt 2359 RETVAL = c99_cbrt(x); 2360 #else 2361 not_here("cbrt"); 2362 #endif 2363 break; 2364 case 7: 2365 RETVAL = Perl_ceil(x); /* C89 math */ 2366 break; 2367 case 8: 2368 RETVAL = Perl_cosh(x); /* C89 math */ 2369 break; 2370 case 9: 2371 #ifdef c99_erf 2372 RETVAL = c99_erf(x); 2373 #else 2374 not_here("erf"); 2375 #endif 2376 break; 2377 case 10: 2378 #ifdef c99_erfc 2379 RETVAL = c99_erfc(x); 2380 #else 2381 not_here("erfc"); 2382 #endif 2383 break; 2384 case 11: 2385 #ifdef c99_exp2 2386 RETVAL = c99_exp2(x); 2387 #else 2388 not_here("exp2"); 2389 #endif 2390 break; 2391 case 12: 2392 #ifdef c99_expm1 2393 RETVAL = c99_expm1(x); 2394 #else 2395 not_here("expm1"); 2396 #endif 2397 break; 2398 case 13: 2399 RETVAL = Perl_floor(x); /* C89 math */ 2400 break; 2401 case 14: 2402 #ifdef bessel_j0 2403 RETVAL = bessel_j0(x); 2404 #else 2405 not_here("j0"); 2406 #endif 2407 break; 2408 case 15: 2409 #ifdef bessel_j1 2410 RETVAL = bessel_j1(x); 2411 #else 2412 not_here("j1"); 2413 #endif 2414 break; 2415 case 16: 2416 /* XXX Note: the lgamma modifies a global variable (signgam), 2417 * which is evil. Some platforms have lgamma_r, which has 2418 * extra output parameter instead of the global variable. */ 2419 #ifdef c99_lgamma 2420 RETVAL = c99_lgamma(x); 2421 #else 2422 not_here("lgamma"); 2423 #endif 2424 break; 2425 case 17: 2426 RETVAL = Perl_log10(x); /* C89 math */ 2427 break; 2428 case 18: 2429 #ifdef c99_log1p 2430 RETVAL = c99_log1p(x); 2431 #else 2432 not_here("log1p"); 2433 #endif 2434 break; 2435 case 19: 2436 #ifdef c99_log2 2437 RETVAL = c99_log2(x); 2438 #else 2439 not_here("log2"); 2440 #endif 2441 break; 2442 case 20: 2443 #ifdef c99_logb 2444 RETVAL = c99_logb(x); 2445 #elif defined(c99_log2) && FLT_RADIX == 2 2446 RETVAL = Perl_floor(c99_log2(PERL_ABS(x))); 2447 #else 2448 not_here("logb"); 2449 #endif 2450 break; 2451 case 21: 2452 #ifdef c99_nearbyint 2453 RETVAL = c99_nearbyint(x); 2454 #else 2455 not_here("nearbyint"); 2456 #endif 2457 break; 2458 case 22: 2459 #ifdef c99_rint 2460 RETVAL = c99_rint(x); 2461 #else 2462 not_here("rint"); 2463 #endif 2464 break; 2465 case 23: 2466 #ifdef c99_round 2467 RETVAL = c99_round(x); 2468 #else 2469 not_here("round"); 2470 #endif 2471 break; 2472 case 24: 2473 RETVAL = Perl_sinh(x); /* C89 math */ 2474 break; 2475 case 25: 2476 RETVAL = Perl_tan(x); /* C89 math */ 2477 break; 2478 case 26: 2479 RETVAL = Perl_tanh(x); /* C89 math */ 2480 break; 2481 case 27: 2482 #ifdef c99_tgamma 2483 RETVAL = c99_tgamma(x); 2484 #else 2485 not_here("tgamma"); 2486 #endif 2487 break; 2488 case 28: 2489 #ifdef c99_trunc 2490 RETVAL = c99_trunc(x); 2491 #else 2492 not_here("trunc"); 2493 #endif 2494 break; 2495 case 29: 2496 #ifdef bessel_y0 2497 RETVAL = bessel_y0(x); 2498 #else 2499 not_here("y0"); 2500 #endif 2501 break; 2502 case 30: 2503 default: 2504 #ifdef bessel_y1 2505 RETVAL = bessel_y1(x); 2506 #else 2507 not_here("y1"); 2508 #endif 2509 } 2510 OUTPUT: 2511 RETVAL 2512 2513 IV 2514 fegetround() 2515 CODE: 2516 #ifdef HAS_FEGETROUND 2517 RETVAL = my_fegetround(); 2518 #else 2519 RETVAL = -1; 2520 not_here("fegetround"); 2521 #endif 2522 OUTPUT: 2523 RETVAL 2524 2525 IV 2526 fesetround(x) 2527 IV x 2528 CODE: 2529 #ifdef HAS_FEGETROUND /* canary for fesetround */ 2530 RETVAL = fesetround(x); 2531 #elif defined(HAS_FPGETROUND) /* canary for fpsetround */ 2532 switch (x) { 2533 case FE_TONEAREST: RETVAL = fpsetround(FP_RN); break; 2534 case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break; 2535 case FE_DOWNWARD: RETVAL = fpsetround(FP_RM); break; 2536 case FE_UPWARD: RETVAL = fpsetround(FP_RP); break; 2537 default: RETVAL = -1; break; 2538 } 2539 #elif defined(__osf__) /* Tru64 */ 2540 switch (x) { 2541 case FE_TONEAREST: RETVAL = write_rnd(FP_RND_RN); break; 2542 case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break; 2543 case FE_DOWNWARD: RETVAL = write_rnd(FP_RND_RM); break; 2544 case FE_UPWARD: RETVAL = write_rnd(FP_RND_RP); break; 2545 default: RETVAL = -1; break; 2546 } 2547 #else 2548 PERL_UNUSED_VAR(x); 2549 RETVAL = -1; 2550 not_here("fesetround"); 2551 #endif 2552 OUTPUT: 2553 RETVAL 2554 2555 IV 2556 fpclassify(x) 2557 NV x 2558 ALIAS: 2559 ilogb = 1 2560 isfinite = 2 2561 isinf = 3 2562 isnan = 4 2563 isnormal = 5 2564 lrint = 6 2565 lround = 7 2566 signbit = 8 2567 CODE: 2568 PERL_UNUSED_VAR(x); 2569 RETVAL = -1; 2570 switch (ix) { 2571 case 0: 2572 #ifdef c99_fpclassify 2573 RETVAL = c99_fpclassify(x); 2574 #else 2575 not_here("fpclassify"); 2576 #endif 2577 break; 2578 case 1: 2579 #ifdef c99_ilogb 2580 RETVAL = c99_ilogb(x); 2581 #else 2582 not_here("ilogb"); 2583 #endif 2584 break; 2585 case 2: 2586 RETVAL = Perl_isfinite(x); 2587 break; 2588 case 3: 2589 RETVAL = Perl_isinf(x); 2590 break; 2591 case 4: 2592 RETVAL = Perl_isnan(x); 2593 break; 2594 case 5: 2595 #ifdef c99_isnormal 2596 RETVAL = c99_isnormal(x); 2597 #else 2598 not_here("isnormal"); 2599 #endif 2600 break; 2601 case 6: 2602 #ifdef c99_lrint 2603 RETVAL = c99_lrint(x); 2604 #else 2605 not_here("lrint"); 2606 #endif 2607 break; 2608 case 7: 2609 #ifdef c99_lround 2610 RETVAL = c99_lround(x); 2611 #else 2612 not_here("lround"); 2613 #endif 2614 break; 2615 case 8: 2616 default: 2617 #ifdef Perl_signbit 2618 RETVAL = Perl_signbit(x); 2619 #else 2620 RETVAL = (x < 0); 2621 #ifdef DOUBLE_IS_IEEE_FORMAT 2622 if (x == -0.0) { 2623 RETVAL = TRUE; 2624 } 2625 #endif 2626 #endif 2627 break; 2628 } 2629 OUTPUT: 2630 RETVAL 2631 2632 NV 2633 getpayload(nv) 2634 NV nv 2635 CODE: 2636 #ifdef DOUBLE_HAS_NAN 2637 RETVAL = S_getpayload(nv); 2638 #else 2639 PERL_UNUSED_VAR(nv); 2640 RETVAL = 0.0; 2641 not_here("getpayload"); 2642 #endif 2643 OUTPUT: 2644 RETVAL 2645 2646 void 2647 setpayload(nv, payload) 2648 NV nv 2649 NV payload 2650 CODE: 2651 #ifdef DOUBLE_HAS_NAN 2652 S_setpayload(&nv, payload, FALSE); 2653 #else 2654 PERL_UNUSED_VAR(nv); 2655 PERL_UNUSED_VAR(payload); 2656 not_here("setpayload"); 2657 #endif 2658 OUTPUT: 2659 nv 2660 2661 void 2662 setpayloadsig(nv, payload) 2663 NV nv 2664 NV payload 2665 CODE: 2666 #ifdef DOUBLE_HAS_NAN 2667 nv = NV_NAN; 2668 S_setpayload(&nv, payload, TRUE); 2669 #else 2670 PERL_UNUSED_VAR(nv); 2671 PERL_UNUSED_VAR(payload); 2672 not_here("setpayloadsig"); 2673 #endif 2674 OUTPUT: 2675 nv 2676 2677 int 2678 issignaling(nv) 2679 NV nv 2680 CODE: 2681 #ifdef DOUBLE_HAS_NAN 2682 RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv); 2683 #else 2684 PERL_UNUSED_VAR(nv); 2685 RETVAL = 0.0; 2686 not_here("issignaling"); 2687 #endif 2688 OUTPUT: 2689 RETVAL 2690 2691 NV 2692 copysign(x,y) 2693 NV x 2694 NV y 2695 ALIAS: 2696 fdim = 1 2697 fmax = 2 2698 fmin = 3 2699 fmod = 4 2700 hypot = 5 2701 isgreater = 6 2702 isgreaterequal = 7 2703 isless = 8 2704 islessequal = 9 2705 islessgreater = 10 2706 isunordered = 11 2707 nextafter = 12 2708 nexttoward = 13 2709 remainder = 14 2710 CODE: 2711 PERL_UNUSED_VAR(x); 2712 PERL_UNUSED_VAR(y); 2713 #ifdef NV_NAN 2714 RETVAL = NV_NAN; 2715 #else 2716 RETVAL = 0; 2717 #endif 2718 switch (ix) { 2719 case 0: 2720 #ifdef c99_copysign 2721 RETVAL = c99_copysign(x, y); 2722 #else 2723 not_here("copysign"); 2724 #endif 2725 break; 2726 case 1: 2727 #ifdef c99_fdim 2728 RETVAL = c99_fdim(x, y); 2729 #else 2730 not_here("fdim"); 2731 #endif 2732 break; 2733 case 2: 2734 #ifdef c99_fmax 2735 RETVAL = c99_fmax(x, y); 2736 #else 2737 not_here("fmax"); 2738 #endif 2739 break; 2740 case 3: 2741 #ifdef c99_fmin 2742 RETVAL = c99_fmin(x, y); 2743 #else 2744 not_here("fmin"); 2745 #endif 2746 break; 2747 case 4: 2748 RETVAL = Perl_fmod(x, y); /* C89 math */ 2749 break; 2750 case 5: 2751 #ifdef c99_hypot 2752 RETVAL = c99_hypot(x, y); 2753 #else 2754 not_here("hypot"); 2755 #endif 2756 break; 2757 case 6: 2758 #ifdef c99_isgreater 2759 RETVAL = c99_isgreater(x, y); 2760 #else 2761 not_here("isgreater"); 2762 #endif 2763 break; 2764 case 7: 2765 #ifdef c99_isgreaterequal 2766 RETVAL = c99_isgreaterequal(x, y); 2767 #else 2768 not_here("isgreaterequal"); 2769 #endif 2770 break; 2771 case 8: 2772 #ifdef c99_isless 2773 RETVAL = c99_isless(x, y); 2774 #else 2775 not_here("isless"); 2776 #endif 2777 break; 2778 case 9: 2779 #ifdef c99_islessequal 2780 RETVAL = c99_islessequal(x, y); 2781 #else 2782 not_here("islessequal"); 2783 #endif 2784 break; 2785 case 10: 2786 #ifdef c99_islessgreater 2787 RETVAL = c99_islessgreater(x, y); 2788 #else 2789 not_here("islessgreater"); 2790 #endif 2791 break; 2792 case 11: 2793 #ifdef c99_isunordered 2794 RETVAL = c99_isunordered(x, y); 2795 #else 2796 not_here("isunordered"); 2797 #endif 2798 break; 2799 case 12: 2800 #ifdef c99_nextafter 2801 RETVAL = c99_nextafter(x, y); 2802 #else 2803 not_here("nextafter"); 2804 #endif 2805 break; 2806 case 13: 2807 #ifdef c99_nexttoward 2808 RETVAL = c99_nexttoward(x, y); 2809 #else 2810 not_here("nexttoward"); 2811 #endif 2812 break; 2813 case 14: 2814 default: 2815 #ifdef c99_remainder 2816 RETVAL = c99_remainder(x, y); 2817 #else 2818 not_here("remainder"); 2819 #endif 2820 break; 2821 } 2822 OUTPUT: 2823 RETVAL 2824 2825 void 2826 frexp(x) 2827 NV x 2828 PPCODE: 2829 int expvar; 2830 /* (We already know stack is long enough.) */ 2831 PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */ 2832 PUSHs(sv_2mortal(newSViv(expvar))); 2833 2834 NV 2835 ldexp(x,exp) 2836 NV x 2837 int exp 2838 CODE: 2839 RETVAL = Perl_ldexp(x, exp); 2840 OUTPUT: 2841 RETVAL 2842 2843 void 2844 modf(x) 2845 NV x 2846 PPCODE: 2847 NV intvar; 2848 /* (We already know stack is long enough.) */ 2849 PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */ 2850 PUSHs(sv_2mortal(newSVnv(intvar))); 2851 2852 void 2853 remquo(x,y) 2854 NV x 2855 NV y 2856 PPCODE: 2857 #ifdef c99_remquo 2858 int intvar; 2859 PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar)))); 2860 PUSHs(sv_2mortal(newSVnv(intvar))); 2861 #else 2862 PERL_UNUSED_VAR(x); 2863 PERL_UNUSED_VAR(y); 2864 not_here("remquo"); 2865 #endif 2866 2867 NV 2868 scalbn(x,y) 2869 NV x 2870 IV y 2871 CODE: 2872 #ifdef c99_scalbn 2873 RETVAL = c99_scalbn(x, y); 2874 #else 2875 PERL_UNUSED_VAR(x); 2876 PERL_UNUSED_VAR(y); 2877 RETVAL = NV_NAN; 2878 not_here("scalbn"); 2879 #endif 2880 OUTPUT: 2881 RETVAL 2882 2883 NV 2884 fma(x,y,z) 2885 NV x 2886 NV y 2887 NV z 2888 CODE: 2889 #ifdef c99_fma 2890 RETVAL = c99_fma(x, y, z); 2891 #else 2892 PERL_UNUSED_VAR(x); 2893 PERL_UNUSED_VAR(y); 2894 PERL_UNUSED_VAR(z); 2895 not_here("fma"); 2896 #endif 2897 OUTPUT: 2898 RETVAL 2899 2900 NV 2901 nan(payload = 0) 2902 NV payload 2903 CODE: 2904 #ifdef NV_NAN 2905 /* If no payload given, just return the default NaN. 2906 * This makes a difference in platforms where the default 2907 * NaN is not all zeros. */ 2908 if (items == 0) { 2909 RETVAL = NV_NAN; 2910 } else { 2911 S_setpayload(&RETVAL, payload, FALSE); 2912 } 2913 #elif defined(c99_nan) 2914 { 2915 STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload); 2916 if ((IV)elen == -1) { 2917 #ifdef NV_NAN 2918 RETVAL = NV_NAN; 2919 #else 2920 RETVAL = 0.0; 2921 not_here("nan"); 2922 #endif 2923 } else { 2924 RETVAL = c99_nan(PL_efloatbuf); 2925 } 2926 } 2927 #else 2928 not_here("nan"); 2929 #endif 2930 OUTPUT: 2931 RETVAL 2932 2933 NV 2934 jn(x,y) 2935 IV x 2936 NV y 2937 ALIAS: 2938 yn = 1 2939 CODE: 2940 #ifdef NV_NAN 2941 RETVAL = NV_NAN; 2942 #else 2943 RETVAL = 0; 2944 #endif 2945 switch (ix) { 2946 case 0: 2947 #ifdef bessel_jn 2948 RETVAL = bessel_jn(x, y); 2949 #else 2950 PERL_UNUSED_VAR(x); 2951 PERL_UNUSED_VAR(y); 2952 not_here("jn"); 2953 #endif 2954 break; 2955 case 1: 2956 default: 2957 #ifdef bessel_yn 2958 RETVAL = bessel_yn(x, y); 2959 #else 2960 PERL_UNUSED_VAR(x); 2961 PERL_UNUSED_VAR(y); 2962 not_here("yn"); 2963 #endif 2964 break; 2965 } 2966 OUTPUT: 2967 RETVAL 2968 2969 SysRet 2970 sigaction(sig, optaction, oldaction = 0) 2971 int sig 2972 SV * optaction 2973 POSIX::SigAction oldaction 2974 CODE: 2975 #if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__)) 2976 RETVAL = not_here("sigaction"); 2977 #else 2978 # This code is really grody because we are trying to make the signal 2979 # interface look beautiful, which is hard. 2980 2981 { 2982 dVAR; 2983 POSIX__SigAction action; 2984 GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV); 2985 struct sigaction act; 2986 struct sigaction oact; 2987 sigset_t sset; 2988 SV *osset_sv; 2989 sigset_t osset; 2990 POSIX__SigSet sigset; 2991 SV** svp; 2992 SV** sigsvp; 2993 2994 if (sig < 0) { 2995 croak("Negative signals are not allowed"); 2996 } 2997 2998 if (sig == 0 && SvPOK(ST(0))) { 2999 const char *s = SvPVX_const(ST(0)); 3000 int i = whichsig(s); 3001 3002 if (i < 0 && memBEGINs(s, SvCUR(ST(0)), "SIG")) 3003 i = whichsig(s + 3); 3004 if (i < 0) { 3005 if (ckWARN(WARN_SIGNAL)) 3006 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), 3007 "No such signal: SIG%s", s); 3008 XSRETURN_UNDEF; 3009 } 3010 else 3011 sig = i; 3012 } 3013 #ifdef NSIG 3014 if (sig > NSIG) { /* NSIG - 1 is still okay. */ 3015 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), 3016 "No such signal: %d", sig); 3017 XSRETURN_UNDEF; 3018 } 3019 #endif 3020 sigsvp = hv_fetch(GvHVn(siggv), 3021 PL_sig_name[sig], 3022 strlen(PL_sig_name[sig]), 3023 TRUE); 3024 3025 /* Check optaction and set action */ 3026 if(SvTRUE(optaction)) { 3027 if(sv_isa(optaction, "POSIX::SigAction")) 3028 action = (HV*)SvRV(optaction); 3029 else 3030 croak("action is not of type POSIX::SigAction"); 3031 } 3032 else { 3033 action=0; 3034 } 3035 3036 /* sigaction() is supposed to look atomic. In particular, any 3037 * signal handler invoked during a sigaction() call should 3038 * see either the old or the new disposition, and not something 3039 * in between. We use sigprocmask() to make it so. 3040 */ 3041 sigfillset(&sset); 3042 RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset); 3043 if(RETVAL == -1) 3044 XSRETURN_UNDEF; 3045 ENTER; 3046 /* Restore signal mask no matter how we exit this block. */ 3047 osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t)); 3048 SAVEFREESV( osset_sv ); 3049 SAVEDESTRUCTOR_X(restore_sigmask, osset_sv); 3050 3051 RETVAL=-1; /* In case both oldaction and action are 0. */ 3052 3053 /* Remember old disposition if desired. */ 3054 if (oldaction) { 3055 svp = hv_fetchs(oldaction, "HANDLER", TRUE); 3056 if(!svp) 3057 croak("Can't supply an oldaction without a HANDLER"); 3058 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */ 3059 sv_setsv(*svp, *sigsvp); 3060 } 3061 else { 3062 sv_setpvs(*svp, "DEFAULT"); 3063 } 3064 RETVAL = sigaction(sig, (struct sigaction *)0, & oact); 3065 if(RETVAL == -1) { 3066 LEAVE; 3067 XSRETURN_UNDEF; 3068 } 3069 /* Get back the mask. */ 3070 svp = hv_fetchs(oldaction, "MASK", TRUE); 3071 if (sv_isa(*svp, "POSIX::SigSet")) { 3072 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp)); 3073 } 3074 else { 3075 sigset = (sigset_t *) allocate_struct(aTHX_ *svp, 3076 sizeof(sigset_t), 3077 "POSIX::SigSet"); 3078 } 3079 *sigset = oact.sa_mask; 3080 3081 /* Get back the flags. */ 3082 svp = hv_fetchs(oldaction, "FLAGS", TRUE); 3083 sv_setiv(*svp, oact.sa_flags); 3084 3085 /* Get back whether the old handler used safe signals. */ 3086 svp = hv_fetchs(oldaction, "SAFE", TRUE); 3087 sv_setiv(*svp, 3088 /* compare incompatible pointers by casting to integer */ 3089 PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp)); 3090 } 3091 3092 if (action) { 3093 /* Safe signals use "csighandler", which vectors through the 3094 PL_sighandlerp pointer when it's safe to do so. 3095 (BTW, "csighandler" is very different from "sighandler".) */ 3096 svp = hv_fetchs(action, "SAFE", FALSE); 3097 act.sa_handler = 3098 DPTR2FPTR( 3099 void (*)(int), 3100 (*svp && SvTRUE(*svp)) 3101 ? PL_csighandlerp : PL_sighandlerp 3102 ); 3103 3104 /* Vector new Perl handler through %SIG. 3105 (The core signal handlers read %SIG to dispatch.) */ 3106 svp = hv_fetchs(action, "HANDLER", FALSE); 3107 if (!svp) 3108 croak("Can't supply an action without a HANDLER"); 3109 sv_setsv(*sigsvp, *svp); 3110 3111 /* This call actually calls sigaction() with almost the 3112 right settings, including appropriate interpretation 3113 of DEFAULT and IGNORE. However, why are we doing 3114 this when we're about to do it again just below? XXX */ 3115 SvSETMAGIC(*sigsvp); 3116 3117 /* And here again we duplicate -- DEFAULT/IGNORE checking. */ 3118 if(SvPOK(*svp)) { 3119 const char *s=SvPVX_const(*svp); 3120 if(strEQ(s,"IGNORE")) { 3121 act.sa_handler = SIG_IGN; 3122 } 3123 else if(strEQ(s,"DEFAULT")) { 3124 act.sa_handler = SIG_DFL; 3125 } 3126 } 3127 3128 /* Set up any desired mask. */ 3129 svp = hv_fetchs(action, "MASK", FALSE); 3130 if (svp && sv_isa(*svp, "POSIX::SigSet")) { 3131 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp)); 3132 act.sa_mask = *sigset; 3133 } 3134 else 3135 sigemptyset(& act.sa_mask); 3136 3137 /* Set up any desired flags. */ 3138 svp = hv_fetchs(action, "FLAGS", FALSE); 3139 act.sa_flags = svp ? SvIV(*svp) : 0; 3140 3141 /* Don't worry about cleaning up *sigsvp if this fails, 3142 * because that means we tried to disposition a 3143 * nonblockable signal, in which case *sigsvp is 3144 * essentially meaningless anyway. 3145 */ 3146 RETVAL = sigaction(sig, & act, (struct sigaction *)0); 3147 if(RETVAL == -1) { 3148 LEAVE; 3149 XSRETURN_UNDEF; 3150 } 3151 } 3152 3153 LEAVE; 3154 } 3155 #endif 3156 OUTPUT: 3157 RETVAL 3158 3159 SysRet 3160 sigpending(sigset) 3161 POSIX::SigSet sigset 3162 ALIAS: 3163 sigsuspend = 1 3164 CODE: 3165 #ifdef __amigaos4__ 3166 RETVAL = not_here("sigpending"); 3167 #else 3168 RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset); 3169 #endif 3170 OUTPUT: 3171 RETVAL 3172 CLEANUP: 3173 PERL_ASYNC_CHECK(); 3174 3175 SysRet 3176 sigprocmask(how, sigset, oldsigset = 0) 3177 int how 3178 POSIX::SigSet sigset = NO_INIT 3179 POSIX::SigSet oldsigset = NO_INIT 3180 INIT: 3181 if (! SvOK(ST(1))) { 3182 sigset = NULL; 3183 } else if (sv_isa(ST(1), "POSIX::SigSet")) { 3184 sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1))); 3185 } else { 3186 croak("sigset is not of type POSIX::SigSet"); 3187 } 3188 3189 if (items < 3 || ! SvOK(ST(2))) { 3190 oldsigset = NULL; 3191 } else if (sv_isa(ST(2), "POSIX::SigSet")) { 3192 oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2))); 3193 } else { 3194 croak("oldsigset is not of type POSIX::SigSet"); 3195 } 3196 3197 void 3198 _exit(status) 3199 int status 3200 3201 SysRet 3202 dup2(fd1, fd2) 3203 int fd1 3204 int fd2 3205 CODE: 3206 if (fd1 >= 0 && fd2 >= 0) { 3207 #ifdef WIN32 3208 /* RT #98912 - More Microsoft muppetry - failing to 3209 actually implemented the well known documented POSIX 3210 behaviour for a POSIX API. 3211 http://msdn.microsoft.com/en-us/library/8syseb29.aspx */ 3212 RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2; 3213 #else 3214 RETVAL = dup2(fd1, fd2); 3215 #endif 3216 } else { 3217 SETERRNO(EBADF,RMS_IFI); 3218 RETVAL = -1; 3219 } 3220 OUTPUT: 3221 RETVAL 3222 3223 SV * 3224 lseek(fd, offset, whence) 3225 POSIX::Fd fd 3226 Off_t offset 3227 int whence 3228 CODE: 3229 { 3230 Off_t pos = PerlLIO_lseek(fd, offset, whence); 3231 RETVAL = sizeof(Off_t) > sizeof(IV) 3232 ? newSVnv((NV)pos) : newSViv((IV)pos); 3233 } 3234 OUTPUT: 3235 RETVAL 3236 3237 void 3238 nice(incr) 3239 int incr 3240 PPCODE: 3241 errno = 0; 3242 if ((incr = nice(incr)) != -1 || errno == 0) { 3243 if (incr == 0) 3244 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP)); 3245 else 3246 XPUSHs(sv_2mortal(newSViv(incr))); 3247 } 3248 3249 void 3250 pipe() 3251 PPCODE: 3252 int fds[2]; 3253 if (pipe(fds) != -1) { 3254 EXTEND(SP,2); 3255 PUSHs(sv_2mortal(newSViv(fds[0]))); 3256 PUSHs(sv_2mortal(newSViv(fds[1]))); 3257 } 3258 3259 SysRet 3260 read(fd, buffer, nbytes) 3261 PREINIT: 3262 SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); 3263 INPUT: 3264 POSIX::Fd fd 3265 size_t nbytes 3266 char * buffer = sv_grow( sv_buffer, nbytes+1 ); 3267 CLEANUP: 3268 if (RETVAL >= 0) { 3269 SvCUR_set(sv_buffer, RETVAL); 3270 SvPOK_only(sv_buffer); 3271 *SvEND(sv_buffer) = '\0'; 3272 SvTAINTED_on(sv_buffer); 3273 } 3274 3275 SysRet 3276 setpgid(pid, pgid) 3277 pid_t pid 3278 pid_t pgid 3279 3280 pid_t 3281 setsid() 3282 3283 pid_t 3284 tcgetpgrp(fd) 3285 POSIX::Fd fd 3286 3287 SysRet 3288 tcsetpgrp(fd, pgrp_id) 3289 POSIX::Fd fd 3290 pid_t pgrp_id 3291 3292 void 3293 uname() 3294 PPCODE: 3295 #ifdef HAS_UNAME 3296 struct utsname buf; 3297 if (uname(&buf) >= 0) { 3298 EXTEND(SP, 5); 3299 PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP)); 3300 PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP)); 3301 PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP)); 3302 PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP)); 3303 PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP)); 3304 } 3305 #else 3306 uname((char *) 0); /* A stub to call not_here(). */ 3307 #endif 3308 3309 SysRet 3310 write(fd, buffer, nbytes) 3311 POSIX::Fd fd 3312 char * buffer 3313 size_t nbytes 3314 3315 void 3316 abort() 3317 3318 #ifdef I_WCHAR 3319 # include <wchar.h> 3320 #endif 3321 3322 int 3323 mblen(s, n) 3324 char * s 3325 size_t n 3326 PREINIT: 3327 #if defined(USE_ITHREADS) && defined(HAS_MBRLEN) 3328 mbstate_t ps; 3329 #endif 3330 CODE: 3331 #if defined(USE_ITHREADS) && defined(HAS_MBRLEN) 3332 memset(&ps, 0, sizeof(ps)); /* Initialize state */ 3333 RETVAL = mbrlen(s, n, &ps); /* Prefer reentrant version */ 3334 #else 3335 /* This might prevent some races, but locales can be switched out 3336 * without locking, so this isn't a cure all */ 3337 LOCALE_LOCK; 3338 3339 RETVAL = mblen(s, n); 3340 LOCALE_UNLOCK; 3341 #endif 3342 OUTPUT: 3343 RETVAL 3344 3345 size_t 3346 mbstowcs(s, pwcs, n) 3347 wchar_t * s 3348 char * pwcs 3349 size_t n 3350 3351 int 3352 mbtowc(pwc, s, n) 3353 wchar_t * pwc 3354 char * s 3355 size_t n 3356 PREINIT: 3357 #if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) 3358 mbstate_t ps; 3359 #endif 3360 CODE: 3361 #if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) 3362 memset(&ps, 0, sizeof(ps));; 3363 PERL_UNUSED_RESULT(mbrtowc(pwc, NULL, 0, &ps));/* Reset any shift state */ 3364 errno = 0; 3365 RETVAL = mbrtowc(pwc, s, n, &ps); /* Prefer reentrant version */ 3366 #else 3367 RETVAL = mbtowc(pwc, s, n); 3368 #endif 3369 OUTPUT: 3370 RETVAL 3371 3372 int 3373 wcstombs(s, pwcs, n) 3374 char * s 3375 wchar_t * pwcs 3376 size_t n 3377 3378 int 3379 wctomb(s, wchar) 3380 char * s 3381 wchar_t wchar 3382 3383 int 3384 strcoll(s1, s2) 3385 char * s1 3386 char * s2 3387 3388 void 3389 strtod(str) 3390 char * str 3391 PREINIT: 3392 double num; 3393 char *unparsed; 3394 PPCODE: 3395 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 3396 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); 3397 num = strtod(str, &unparsed); 3398 RESTORE_LC_NUMERIC(); 3399 PUSHs(sv_2mortal(newSVnv(num))); 3400 if (GIMME_V == G_ARRAY) { 3401 EXTEND(SP, 1); 3402 if (unparsed) 3403 PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); 3404 else 3405 PUSHs(&PL_sv_undef); 3406 } 3407 3408 #ifdef HAS_STRTOLD 3409 3410 void 3411 strtold(str) 3412 char * str 3413 PREINIT: 3414 long double num; 3415 char *unparsed; 3416 PPCODE: 3417 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 3418 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); 3419 num = strtold(str, &unparsed); 3420 RESTORE_LC_NUMERIC(); 3421 PUSHs(sv_2mortal(newSVnv(num))); 3422 if (GIMME_V == G_ARRAY) { 3423 EXTEND(SP, 1); 3424 if (unparsed) 3425 PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); 3426 else 3427 PUSHs(&PL_sv_undef); 3428 } 3429 3430 #endif 3431 3432 void 3433 strtol(str, base = 0) 3434 char * str 3435 int base 3436 PREINIT: 3437 long num; 3438 char *unparsed; 3439 PPCODE: 3440 if (base == 0 || inRANGE(base, 2, 36)) { 3441 num = strtol(str, &unparsed, base); 3442 #if IVSIZE < LONGSIZE 3443 if (num < IV_MIN || num > IV_MAX) 3444 PUSHs(sv_2mortal(newSVnv((double)num))); 3445 else 3446 #endif 3447 PUSHs(sv_2mortal(newSViv((IV)num))); 3448 if (GIMME_V == G_ARRAY) { 3449 EXTEND(SP, 1); 3450 if (unparsed) 3451 PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); 3452 else 3453 PUSHs(&PL_sv_undef); 3454 } 3455 } else { 3456 SETERRNO(EINVAL, LIB_INVARG); 3457 PUSHs(&PL_sv_undef); 3458 if (GIMME_V == G_ARRAY) { 3459 EXTEND(SP, 1); 3460 PUSHs(&PL_sv_undef); 3461 } 3462 } 3463 3464 void 3465 strtoul(str, base = 0) 3466 const char * str 3467 int base 3468 PREINIT: 3469 unsigned long num; 3470 char *unparsed = NULL; 3471 PPCODE: 3472 PERL_UNUSED_VAR(str); 3473 PERL_UNUSED_VAR(base); 3474 if (base == 0 || inRANGE(base, 2, 36)) { 3475 num = strtoul(str, &unparsed, base); 3476 #if IVSIZE <= LONGSIZE 3477 if (num > IV_MAX) 3478 PUSHs(sv_2mortal(newSVnv((double)num))); 3479 else 3480 #endif 3481 PUSHs(sv_2mortal(newSViv((IV)num))); 3482 if (GIMME_V == G_ARRAY) { 3483 EXTEND(SP, 1); 3484 if (unparsed) 3485 PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); 3486 else 3487 PUSHs(&PL_sv_undef); 3488 } 3489 } else { 3490 SETERRNO(EINVAL, LIB_INVARG); 3491 PUSHs(&PL_sv_undef); 3492 if (GIMME_V == G_ARRAY) { 3493 EXTEND(SP, 1); 3494 PUSHs(&PL_sv_undef); 3495 } 3496 } 3497 3498 void 3499 strxfrm(src) 3500 SV * src 3501 CODE: 3502 { 3503 STRLEN srclen; 3504 STRLEN dstlen; 3505 STRLEN buflen; 3506 char *p = SvPV(src,srclen); 3507 srclen++; 3508 buflen = srclen * 4 + 1; 3509 ST(0) = sv_2mortal(newSV(buflen)); 3510 dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen); 3511 if (dstlen >= buflen) { 3512 dstlen++; 3513 SvGROW(ST(0), dstlen); 3514 strxfrm(SvPVX(ST(0)), p, (size_t)dstlen); 3515 dstlen--; 3516 } 3517 SvCUR_set(ST(0), dstlen); 3518 SvPOK_only(ST(0)); 3519 } 3520 3521 SysRet 3522 mkfifo(filename, mode) 3523 char * filename 3524 Mode_t mode 3525 ALIAS: 3526 access = 1 3527 CODE: 3528 if(ix) { 3529 RETVAL = access(filename, mode); 3530 } else { 3531 TAINT_PROPER("mkfifo"); 3532 RETVAL = mkfifo(filename, mode); 3533 } 3534 OUTPUT: 3535 RETVAL 3536 3537 SysRet 3538 tcdrain(fd) 3539 POSIX::Fd fd 3540 ALIAS: 3541 close = 1 3542 dup = 2 3543 CODE: 3544 if (fd >= 0) { 3545 RETVAL = ix == 1 ? close(fd) 3546 : (ix < 1 ? tcdrain(fd) : dup(fd)); 3547 } else { 3548 SETERRNO(EBADF,RMS_IFI); 3549 RETVAL = -1; 3550 } 3551 OUTPUT: 3552 RETVAL 3553 3554 3555 SysRet 3556 tcflow(fd, action) 3557 POSIX::Fd fd 3558 int action 3559 ALIAS: 3560 tcflush = 1 3561 tcsendbreak = 2 3562 CODE: 3563 if (action >= 0) { 3564 RETVAL = ix == 1 ? tcflush(fd, action) 3565 : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action)); 3566 } else { 3567 SETERRNO(EINVAL,LIB_INVARG); 3568 RETVAL = -1; 3569 } 3570 OUTPUT: 3571 RETVAL 3572 3573 void 3574 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) 3575 int sec 3576 int min 3577 int hour 3578 int mday 3579 int mon 3580 int year 3581 int wday 3582 int yday 3583 int isdst 3584 ALIAS: 3585 mktime = 1 3586 PPCODE: 3587 { 3588 dXSTARG; 3589 struct tm mytm; 3590 init_tm(&mytm); /* XXX workaround - see init_tm() in core util.c */ 3591 mytm.tm_sec = sec; 3592 mytm.tm_min = min; 3593 mytm.tm_hour = hour; 3594 mytm.tm_mday = mday; 3595 mytm.tm_mon = mon; 3596 mytm.tm_year = year; 3597 mytm.tm_wday = wday; 3598 mytm.tm_yday = yday; 3599 mytm.tm_isdst = isdst; 3600 if (ix) { 3601 const time_t result = mktime(&mytm); 3602 if (result == (time_t)-1) 3603 SvOK_off(TARG); 3604 else if (result == 0) 3605 sv_setpvs(TARG, "0 but true"); 3606 else 3607 sv_setiv(TARG, (IV)result); 3608 } else { 3609 sv_setpv(TARG, asctime(&mytm)); 3610 } 3611 ST(0) = TARG; 3612 XSRETURN(1); 3613 } 3614 3615 long 3616 clock() 3617 3618 char * 3619 ctime(time) 3620 Time_t &time 3621 3622 void 3623 times() 3624 PPCODE: 3625 struct tms tms; 3626 clock_t realtime; 3627 realtime = times( &tms ); 3628 EXTEND(SP,5); 3629 PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) ); 3630 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) ); 3631 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) ); 3632 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) ); 3633 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) ); 3634 3635 double 3636 difftime(time1, time2) 3637 Time_t time1 3638 Time_t time2 3639 3640 #XXX: if $xsubpp::WantOptimize is always the default 3641 # sv_setpv(TARG, ...) could be used rather than 3642 # ST(0) = sv_2mortal(newSVpv(...)) 3643 void 3644 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) 3645 SV * fmt 3646 int sec 3647 int min 3648 int hour 3649 int mday 3650 int mon 3651 int year 3652 int wday 3653 int yday 3654 int isdst 3655 CODE: 3656 { 3657 char *buf; 3658 SV *sv; 3659 3660 /* allowing user-supplied (rather than literal) formats 3661 * is normally frowned upon as a potential security risk; 3662 * but this is part of the API so we have to allow it */ 3663 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); 3664 buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst); 3665 GCC_DIAG_RESTORE_STMT; 3666 sv = sv_newmortal(); 3667 if (buf) { 3668 STRLEN len = strlen(buf); 3669 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL); 3670 if ( SvUTF8(fmt) 3671 || ( is_utf8_non_invariant_string((U8*) buf, len) 3672 #ifdef USE_LOCALE_TIME 3673 && _is_cur_LC_category_utf8(LC_TIME) 3674 #else /* If can't check directly, at least can see if script is consistent, 3675 under UTF-8, which gives us an extra measure of confidence. */ 3676 3677 && isSCRIPT_RUN((const U8 *) buf, 3678 (const U8 *) buf + len, 3679 TRUE) /* Means assume UTF-8 */ 3680 #endif 3681 )) { 3682 SvUTF8_on(sv); 3683 } 3684 } 3685 else { /* We can't distinguish between errors and just an empty 3686 * return; in all cases just return an empty string */ 3687 SvUPGRADE(sv, SVt_PV); 3688 SvPV_set(sv, (char *) ""); 3689 SvPOK_on(sv); 3690 SvCUR_set(sv, 0); 3691 SvLEN_set(sv, 0); /* Won't attempt to free the string when sv 3692 gets destroyed */ 3693 } 3694 ST(0) = sv; 3695 } 3696 3697 void 3698 tzset() 3699 PPCODE: 3700 my_tzset(aTHX); 3701 3702 void 3703 tzname() 3704 PPCODE: 3705 EXTEND(SP,2); 3706 PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP)); 3707 PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP)); 3708 3709 char * 3710 ctermid(s = 0) 3711 char * s = 0; 3712 CODE: 3713 #ifdef HAS_CTERMID_R 3714 s = (char *) safemalloc((size_t) L_ctermid); 3715 #endif 3716 RETVAL = ctermid(s); 3717 OUTPUT: 3718 RETVAL 3719 CLEANUP: 3720 #ifdef HAS_CTERMID_R 3721 Safefree(s); 3722 #endif 3723 3724 char * 3725 cuserid(s = 0) 3726 char * s = 0; 3727 CODE: 3728 #ifdef HAS_CUSERID 3729 RETVAL = cuserid(s); 3730 #else 3731 PERL_UNUSED_VAR(s); 3732 RETVAL = 0; 3733 not_here("cuserid"); 3734 #endif 3735 OUTPUT: 3736 RETVAL 3737 3738 SysRetLong 3739 fpathconf(fd, name) 3740 POSIX::Fd fd 3741 int name 3742 3743 SysRetLong 3744 pathconf(filename, name) 3745 char * filename 3746 int name 3747 3748 SysRet 3749 pause() 3750 CLEANUP: 3751 PERL_ASYNC_CHECK(); 3752 3753 unsigned int 3754 sleep(seconds) 3755 unsigned int seconds 3756 CODE: 3757 RETVAL = PerlProc_sleep(seconds); 3758 OUTPUT: 3759 RETVAL 3760 3761 SysRet 3762 setgid(gid) 3763 Gid_t gid 3764 3765 SysRet 3766 setuid(uid) 3767 Uid_t uid 3768 3769 SysRetLong 3770 sysconf(name) 3771 int name 3772 3773 char * 3774 ttyname(fd) 3775 POSIX::Fd fd 3776 3777 void 3778 getcwd() 3779 PPCODE: 3780 { 3781 dXSTARG; 3782 getcwd_sv(TARG); 3783 XSprePUSH; PUSHTARG; 3784 } 3785 3786 SysRet 3787 lchown(uid, gid, path) 3788 Uid_t uid 3789 Gid_t gid 3790 char * path 3791 CODE: 3792 #ifdef HAS_LCHOWN 3793 /* yes, the order of arguments is different, 3794 * but consistent with CORE::chown() */ 3795 RETVAL = lchown(path, uid, gid); 3796 #else 3797 PERL_UNUSED_VAR(uid); 3798 PERL_UNUSED_VAR(gid); 3799 PERL_UNUSED_VAR(path); 3800 RETVAL = not_here("lchown"); 3801 #endif 3802 OUTPUT: 3803 RETVAL 3804