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