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