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