ext/POSIX/POSIX.xs

   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 #ifndef HAS_MBLEN
1546 #ifndef mblen
1547 #define mblen(a,b) not_here("mblen")
1548 #endif
1549 #endif
1550 #ifndef HAS_MBSTOWCS
1551 #define mbstowcs(s, pwcs, n) not_here("mbstowcs")
1552 #endif
1553 #ifndef HAS_MBTOWC
1554 #define mbtowc(pwc, s, n) not_here("mbtowc")
1555 #endif
1556 #ifndef HAS_WCSTOMBS
1557 #define wcstombs(s, pwcs, n) not_here("wcstombs")
1558 #endif
1559 #ifndef HAS_WCTOMB
1560 #define wctomb(s, wchar) not_here("wcstombs")
1561 #endif
1562 #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
1563 /* If we don't have these functions, then we wouldn't have gotten a typedef
1564    for wchar_t, the wide character type.  Defining wchar_t allows the
1565    functions referencing it to compile.  Its actual type is then meaningless,
1566    since without the above functions, all sections using it end up calling
1567    not_here() and croak.  --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
1568 #ifndef wchar_t
1569 #define wchar_t char
1570 #endif
1571 #endif
1572
1573 #ifndef HAS_LOCALECONV
1574 #   define localeconv() not_here("localeconv")
1575 #else
1576 struct lconv_offset {
1577     const char *name;
1578     size_t offset;
1579 };
1580
1581 static const struct lconv_offset lconv_strings[] = {
1582 #ifdef USE_LOCALE_NUMERIC
1583     {"decimal_point",     STRUCT_OFFSET(struct lconv, decimal_point)},
1584     {"thousands_sep",     STRUCT_OFFSET(struct lconv, thousands_sep)},
1585 #  ifndef NO_LOCALECONV_GROUPING
1586     {"grouping",          STRUCT_OFFSET(struct lconv, grouping)},
1587 #  endif
1588 #endif
1589 #ifdef USE_LOCALE_MONETARY
1590     {"int_curr_symbol",   STRUCT_OFFSET(struct lconv, int_curr_symbol)},
1591     {"currency_symbol",   STRUCT_OFFSET(struct lconv, currency_symbol)},
1592     {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)},
1593 #  ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
1594     {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)},
1595 #  endif
1596 #  ifndef NO_LOCALECONV_MON_GROUPING
1597     {"mon_grouping",      STRUCT_OFFSET(struct lconv, mon_grouping)},
1598 #  endif
1599     {"positive_sign",     STRUCT_OFFSET(struct lconv, positive_sign)},
1600     {"negative_sign",     STRUCT_OFFSET(struct lconv, negative_sign)},
1601 #endif
1602     {NULL, 0}
1603 };
1604
1605 #ifdef USE_LOCALE_NUMERIC
1606
1607 /* The Linux man pages say these are the field names for the structure
1608  * components that are LC_NUMERIC; the rest being LC_MONETARY */
1609 #   define isLC_NUMERIC_STRING(name) (   strEQ(name, "decimal_point")   \
1610                                       || strEQ(name, "thousands_sep")   \
1611                                                                         \
1612                                       /* There should be no harm done   \
1613                                        * checking for this, even if     \
1614                                        * NO_LOCALECONV_GROUPING */      \
1615                                       || strEQ(name, "grouping"))
1616 #else
1617 #   define isLC_NUMERIC_STRING(name) (0)
1618 #endif
1619
1620 static const struct lconv_offset lconv_integers[] = {
1621 #ifdef USE_LOCALE_MONETARY
1622     {"int_frac_digits",   STRUCT_OFFSET(struct lconv, int_frac_digits)},
1623     {"frac_digits",       STRUCT_OFFSET(struct lconv, frac_digits)},
1624     {"p_cs_precedes",     STRUCT_OFFSET(struct lconv, p_cs_precedes)},
1625     {"p_sep_by_space",    STRUCT_OFFSET(struct lconv, p_sep_by_space)},
1626     {"n_cs_precedes",     STRUCT_OFFSET(struct lconv, n_cs_precedes)},
1627     {"n_sep_by_space",    STRUCT_OFFSET(struct lconv, n_sep_by_space)},
1628     {"p_sign_posn",       STRUCT_OFFSET(struct lconv, p_sign_posn)},
1629     {"n_sign_posn",       STRUCT_OFFSET(struct lconv, n_sign_posn)},
1630 #ifdef HAS_LC_MONETARY_2008
1631     {"int_p_cs_precedes",  STRUCT_OFFSET(struct lconv, int_p_cs_precedes)},
1632     {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)},
1633     {"int_n_cs_precedes",  STRUCT_OFFSET(struct lconv, int_n_cs_precedes)},
1634     {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)},
1635     {"int_p_sign_posn",    STRUCT_OFFSET(struct lconv, int_p_sign_posn)},
1636     {"int_n_sign_posn",    STRUCT_OFFSET(struct lconv, int_n_sign_posn)},
1637 #endif
1638 #endif
1639     {NULL, 0}
1640 };
1641
1642 #endif /* HAS_LOCALECONV */
1643
1644 #ifdef HAS_LONG_DOUBLE
1645 #  if LONG_DOUBLESIZE > NVSIZE
1646 #    undef HAS_LONG_DOUBLE  /* XXX until we figure out how to use them */
1647 #  endif
1648 #endif
1649
1650 #ifndef HAS_LONG_DOUBLE
1651 #ifdef LDBL_MAX
1652 #undef LDBL_MAX
1653 #endif
1654 #ifdef LDBL_MIN
1655 #undef LDBL_MIN
1656 #endif
1657 #ifdef LDBL_EPSILON
1658 #undef LDBL_EPSILON
1659 #endif
1660 #endif
1661
1662 /* Background: in most systems the low byte of the wait status
1663  * is the signal (the lowest 7 bits) and the coredump flag is
1664  * the eight bit, and the second lowest byte is the exit status.
1665  * BeOS bucks the trend and has the bytes in different order.
1666  * See beos/beos.c for how the reality is bent even in BeOS
1667  * to follow the traditional.  However, to make the POSIX
1668  * wait W*() macros to work in BeOS, we need to unbend the
1669  * reality back in place. --jhi */
1670 /* In actual fact the code below is to blame here. Perl has an internal
1671  * representation of the exit status ($?), which it re-composes from the
1672  * OS's representation using the W*() POSIX macros. The code below
1673  * incorrectly uses the W*() macros on the internal representation,
1674  * which fails for OSs that have a different representation (namely BeOS
1675  * and Haiku). WMUNGE() is a hack that converts the internal
1676  * representation into the OS specific one, so that the W*() macros work
1677  * as expected. The better solution would be not to use the W*() macros
1678  * in the first place, though. -- Ingo Weinhold
1679  */
1680 #if defined(__HAIKU__)
1681 #    define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
1682 #else
1683 #    define WMUNGE(x) (x)
1684 #endif
1685
1686 static int
1687 not_here(const char *s)
1688 {
1689     croak("POSIX::%s not implemented on this architecture", s);
1690     return -1;
1691 }
1692
1693 #include "const-c.inc"
1694
1695 static void
1696 restore_sigmask(pTHX_ SV *osset_sv)
1697 {
1698      /* Fortunately, restoring the signal mask can't fail, because
1699       * there's nothing we can do about it if it does -- we're not
1700       * supposed to return -1 from sigaction unless the disposition
1701       * was unaffected.
1702       */
1703 #if !(defined(__amigaos4__) && defined(__NEWLIB__))
1704      sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
1705      (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1706 #endif
1707 }
1708
1709 static void *
1710 allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
1711     SV *const t = newSVrv(rv, packname);
1712     void *const p = sv_grow(t, size + 1);
1713
1714     /* Ensure at least one use of not_here() to avoid "defined but not
1715      * used" warning.  This is not at all related to allocate_struct(); I
1716      * just needed somewhere to dump it - DAPM */
1717     if (0) { not_here(""); }
1718
1719     SvCUR_set(t, size);
1720     SvPOK_on(t);
1721     return p;
1722 }
1723
1724 #ifdef WIN32
1725
1726 /*
1727  * (1) The CRT maintains its own copy of the environment, separate from
1728  * the Win32API copy.
1729  *
1730  * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
1731  * copy, and then calls SetEnvironmentVariableA() to update the Win32API
1732  * copy.
1733  *
1734  * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
1735  * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
1736  * environment.
1737  *
1738  * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
1739  * calls CRT tzset(), but only the first time it is called, and in turn
1740  * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
1741  * local copy of the environment and hence gets the original setting as
1742  * perl never updates the CRT copy when assigning to $ENV{TZ}.
1743  *
1744  * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
1745  * putenv() to update the CRT copy of the environment (if it is different)
1746  * whenever we're about to call tzset().
1747  *
1748  * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
1749  * defined:
1750  *
1751  * (a) Each interpreter has its own copy of the environment inside the
1752  * perlhost structure. That allows applications that host multiple
1753  * independent Perl interpreters to isolate environment changes from
1754  * each other. (This is similar to how the perlhost mechanism keeps a
1755  * separate working directory for each Perl interpreter, so that calling
1756  * chdir() will not affect other interpreters.)
1757  *
1758  * (b) Only the first Perl interpreter instantiated within a process will
1759  * "write through" environment changes to the process environment.
1760  *
1761  * (c) Even the primary Perl interpreter won't update the CRT copy of the
1762  * the environment, only the Win32API copy (it calls win32_putenv()).
1763  *
1764  * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
1765  * sense to only update the process environment when inside the main
1766  * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
1767  * from here so we'll just have to check PL_curinterp instead.
1768  *
1769  * Therefore, we can simply #undef getenv() and putenv() so that those names
1770  * always refer to the CRT functions, and explicitly call win32_getenv() to
1771  * access perl's %ENV.
1772  *
1773  * We also #undef malloc() and free() to be sure we are using the CRT
1774  * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
1775  * into VMem::Malloc() and VMem::Free() and all allocations will be freed
1776  * when the Perl interpreter is being destroyed so we'd end up with a pointer
1777  * into deallocated memory in environ[] if a program embedding a Perl
1778  * interpreter continues to operate even after the main Perl interpreter has
1779  * been destroyed.
1780  *
1781  * Note that we don't free() the malloc()ed memory unless and until we call
1782  * malloc() again ourselves because the CRT putenv() function simply puts its
1783  * pointer argument into the environ[] array (it doesn't make a copy of it)
1784  * so this memory must otherwise be leaked.
1785  */
1786
1787 #undef getenv
1788 #undef putenv
1789 #undef malloc
1790 #undef free
1791
1792 static void
1793 fix_win32_tzenv(void)
1794 {
1795     static char* oldenv = NULL;
1796     char* newenv;
1797     const char* perl_tz_env = win32_getenv("TZ");
1798     const char* crt_tz_env = getenv("TZ");
1799     if (perl_tz_env == NULL)
1800         perl_tz_env = "";
1801     if (crt_tz_env == NULL)
1802         crt_tz_env = "";
1803     if (strNE(perl_tz_env, crt_tz_env)) {
1804         newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
1805         if (newenv != NULL) {
1806             sprintf(newenv, "TZ=%s", perl_tz_env);
1807             putenv(newenv);
1808             if (oldenv != NULL)
1809                 free(oldenv);
1810             oldenv = newenv;
1811         }
1812     }
1813 }
1814
1815 #endif
1816
1817 /*
1818  * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
1819  * This code is duplicated in the Time-Piece module, so any changes made here
1820  * should be made there too.
1821  */
1822 static void
1823 my_tzset(pTHX)
1824 {
1825 #ifdef WIN32
1826 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
1827     if (PL_curinterp == aTHX)
1828 #endif
1829         fix_win32_tzenv();
1830 #endif
1831     tzset();
1832 }
1833
1834 MODULE = SigSet         PACKAGE = POSIX::SigSet         PREFIX = sig
1835
1836 void
1837 new(packname = "POSIX::SigSet", ...)
1838     const char *        packname
1839     CODE:
1840         {
1841             int i;
1842             sigset_t *const s
1843                 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1844                                                sizeof(sigset_t),
1845                                                packname);
1846             sigemptyset(s);
1847             for (i = 1; i < items; i++)
1848                 sigaddset(s, SvIV(ST(i)));
1849             XSRETURN(1);
1850         }
1851
1852 SysRet
1853 addset(sigset, sig)
1854         POSIX::SigSet   sigset
1855         POSIX::SigNo    sig
1856    ALIAS:
1857         delset = 1
1858    CODE:
1859         RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
1860    OUTPUT:
1861         RETVAL
1862
1863 SysRet
1864 emptyset(sigset)
1865         POSIX::SigSet   sigset
1866    ALIAS:
1867         fillset = 1
1868    CODE:
1869         RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
1870    OUTPUT:
1871         RETVAL
1872
1873 int
1874 sigismember(sigset, sig)
1875         POSIX::SigSet   sigset
1876         POSIX::SigNo    sig
1877
1878 MODULE = Termios        PACKAGE = POSIX::Termios        PREFIX = cf
1879
1880 void
1881 new(packname = "POSIX::Termios", ...)
1882     const char *        packname
1883     CODE:
1884         {
1885 #ifdef I_TERMIOS
1886             void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1887                                             sizeof(struct termios), packname);
1888             /* The previous implementation stored a pointer to an uninitialised
1889                struct termios. Seems safer to initialise it, particularly as
1890                this implementation exposes the struct to prying from perl-space.
1891             */
1892             memset(p, 0, 1 + sizeof(struct termios));
1893             XSRETURN(1);
1894 #else
1895             not_here("termios");
1896 #endif
1897         }
1898
1899 SysRet
1900 getattr(termios_ref, fd = 0)
1901         POSIX::Termios  termios_ref
1902         POSIX::Fd               fd
1903     CODE:
1904         RETVAL = tcgetattr(fd, termios_ref);
1905     OUTPUT:
1906         RETVAL
1907
1908     # If we define TCSANOW here then both a found and not found constant sub
1909     # are created causing a Constant subroutine TCSANOW redefined warning
1910
1911 #ifndef TCSANOW
1912 #  define DEF_SETATTR_ACTION 0
1913 #else
1914 #  define DEF_SETATTR_ACTION TCSANOW
1915 #endif
1916 SysRet
1917 setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
1918         POSIX::Termios  termios_ref
1919         POSIX::Fd       fd
1920         int             optional_actions
1921     CODE:
1922         /* The second argument to the call is mandatory, but we'd like to give
1923            it a useful default. 0 isn't valid on all operating systems - on
1924            Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
1925            values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF.  */
1926         if (optional_actions < 0) {
1927             SETERRNO(EINVAL, LIB_INVARG);
1928             RETVAL = -1;
1929         } else {
1930             RETVAL = tcsetattr(fd, optional_actions, termios_ref);
1931         }
1932     OUTPUT:
1933         RETVAL
1934
1935 speed_t
1936 getispeed(termios_ref)
1937         POSIX::Termios  termios_ref
1938     ALIAS:
1939         getospeed = 1
1940     CODE:
1941         RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
1942     OUTPUT:
1943         RETVAL
1944
1945 tcflag_t
1946 getiflag(termios_ref)
1947         POSIX::Termios  termios_ref
1948     ALIAS:
1949         getoflag = 1
1950         getcflag = 2
1951         getlflag = 3
1952     CODE:
1953 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1954         switch(ix) {
1955         case 0:
1956             RETVAL = termios_ref->c_iflag;
1957             break;
1958         case 1:
1959             RETVAL = termios_ref->c_oflag;
1960             break;
1961         case 2:
1962             RETVAL = termios_ref->c_cflag;
1963             break;
1964         case 3:
1965             RETVAL = termios_ref->c_lflag;
1966             break;
1967         default:
1968             RETVAL = 0; /* silence compiler warning */
1969         }
1970 #else
1971         not_here(GvNAME(CvGV(cv)));
1972         RETVAL = 0;
1973 #endif
1974     OUTPUT:
1975         RETVAL
1976
1977 cc_t
1978 getcc(termios_ref, ccix)
1979         POSIX::Termios  termios_ref
1980         unsigned int    ccix
1981     CODE:
1982 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1983         if (ccix >= NCCS)
1984             croak("Bad getcc subscript");
1985         RETVAL = termios_ref->c_cc[ccix];
1986 #else
1987      not_here("getcc");
1988      RETVAL = 0;
1989 #endif
1990     OUTPUT:
1991         RETVAL
1992
1993 SysRet
1994 setispeed(termios_ref, speed)
1995         POSIX::Termios  termios_ref
1996         speed_t         speed
1997     ALIAS:
1998         setospeed = 1
1999     CODE:
2000         RETVAL = ix
2001             ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
2002     OUTPUT:
2003         RETVAL
2004
2005 void
2006 setiflag(termios_ref, flag)
2007         POSIX::Termios  termios_ref
2008         tcflag_t        flag
2009     ALIAS:
2010         setoflag = 1
2011         setcflag = 2
2012         setlflag = 3
2013     CODE:
2014 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2015         switch(ix) {
2016         case 0:
2017             termios_ref->c_iflag = flag;
2018             break;
2019         case 1:
2020             termios_ref->c_oflag = flag;
2021             break;
2022         case 2:
2023             termios_ref->c_cflag = flag;
2024             break;
2025         case 3:
2026             termios_ref->c_lflag = flag;
2027             break;
2028         }
2029 #else
2030         not_here(GvNAME(CvGV(cv)));
2031 #endif
2032
2033 void
2034 setcc(termios_ref, ccix, cc)
2035         POSIX::Termios  termios_ref
2036         unsigned int    ccix
2037         cc_t            cc
2038     CODE:
2039 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2040         if (ccix >= NCCS)
2041             croak("Bad setcc subscript");
2042         termios_ref->c_cc[ccix] = cc;
2043 #else
2044             not_here("setcc");
2045 #endif
2046
2047
2048 MODULE = POSIX          PACKAGE = POSIX
2049
2050 INCLUDE: const-xs.inc
2051
2052 int
2053 WEXITSTATUS(status)
2054         int status
2055     ALIAS:
2056         POSIX::WIFEXITED = 1
2057         POSIX::WIFSIGNALED = 2
2058         POSIX::WIFSTOPPED = 3
2059         POSIX::WSTOPSIG = 4
2060         POSIX::WTERMSIG = 5
2061     CODE:
2062 #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
2063       || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
2064         RETVAL = 0; /* Silence compilers that notice this, but don't realise
2065                        that not_here() can't return.  */
2066 #endif
2067         switch(ix) {
2068         case 0:
2069 #ifdef WEXITSTATUS
2070             RETVAL = WEXITSTATUS(WMUNGE(status));
2071 #else
2072             not_here("WEXITSTATUS");
2073 #endif
2074             break;
2075         case 1:
2076 #ifdef WIFEXITED
2077             RETVAL = WIFEXITED(WMUNGE(status));
2078 #else
2079             not_here("WIFEXITED");
2080 #endif
2081             break;
2082         case 2:
2083 #ifdef WIFSIGNALED
2084             RETVAL = WIFSIGNALED(WMUNGE(status));
2085 #else
2086             not_here("WIFSIGNALED");
2087 #endif
2088             break;
2089         case 3:
2090 #ifdef WIFSTOPPED
2091             RETVAL = WIFSTOPPED(WMUNGE(status));
2092 #else
2093             not_here("WIFSTOPPED");
2094 #endif
2095             break;
2096         case 4:
2097 #ifdef WSTOPSIG
2098             RETVAL = WSTOPSIG(WMUNGE(status));
2099 #else
2100             not_here("WSTOPSIG");
2101 #endif
2102             break;
2103         case 5:
2104 #ifdef WTERMSIG
2105             RETVAL = WTERMSIG(WMUNGE(status));
2106 #else
2107             not_here("WTERMSIG");
2108 #endif
2109             break;
2110         default:
2111             croak("Illegal alias %d for POSIX::W*", (int)ix);
2112         }
2113     OUTPUT:
2114         RETVAL
2115
2116 SysRet
2117 open(filename, flags = O_RDONLY, mode = 0666)
2118         char *          filename
2119         int             flags
2120         Mode_t          mode
2121     CODE:
2122         if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
2123             TAINT_PROPER("open");
2124         RETVAL = open(filename, flags, mode);
2125     OUTPUT:
2126         RETVAL
2127
2128
2129 HV *
2130 localeconv()
2131     CODE:
2132 #ifndef HAS_LOCALECONV
2133         localeconv(); /* A stub to call not_here(). */
2134 #else
2135         struct lconv *lcbuf;
2136 #  if defined(USE_ITHREADS)                                             \
2137    && defined(HAS_POSIX_2008_LOCALE)                                    \
2138    && defined(HAS_LOCALECONV_L) /* Prefer this thread-safe version */
2139         bool do_free = FALSE;
2140         locale_t cur = NULL;
2141 #  elif defined(TS_W32_BROKEN_LOCALECONV)
2142         const char * save_global;
2143         const char * save_thread;
2144 #  endif
2145         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2146
2147         /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
2148          * LC_MONETARY is already in the correct locale */
2149 #  ifdef USE_LOCALE_MONETARY
2150
2151         const bool is_monetary_utf8 = _is_cur_LC_category_utf8(LC_MONETARY);
2152 #  endif
2153 #  ifdef USE_LOCALE_NUMERIC
2154
2155         bool is_numeric_utf8;
2156
2157         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2158
2159         is_numeric_utf8 = _is_cur_LC_category_utf8(LC_NUMERIC);
2160 #  endif
2161
2162         RETVAL = newHV();
2163         sv_2mortal((SV*)RETVAL);
2164 #  if defined(USE_ITHREADS)                         \
2165    && defined(HAS_POSIX_2008_LOCALE)                \
2166    && defined(HAS_LOCALECONV_L)                     \
2167    && defined(HAS_DUPLOCALE)
2168
2169         cur = uselocale((locale_t) 0);
2170         if (cur == LC_GLOBAL_LOCALE) {
2171             cur = duplocale(LC_GLOBAL_LOCALE);
2172             do_free = TRUE;
2173         }
2174
2175         lcbuf = localeconv_l(cur);
2176 #  else
2177         LOCALE_LOCK_V;  /* Prevent interference with other threads using
2178                            localeconv() */
2179 #    ifdef TS_W32_BROKEN_LOCALECONV
2180         /* This is a workaround for a Windows bug prior to VS 15, in which
2181          * localeconv only looks at the global locale.  We toggle to the global
2182          * locale; populate the return; then toggle back.  We have to use
2183          * LC_ALL instead of the individual ones because of another bug in
2184          * Windows */
2185
2186         save_thread  = savepv(Perl_setlocale(LC_NUMERIC, NULL));
2187
2188         _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
2189
2190         save_global  = savepv(Perl_setlocale(LC_ALL, NULL));
2191
2192         Perl_setlocale(LC_ALL,  save_thread);
2193 #    endif
2194         lcbuf = localeconv();
2195 #  endif
2196         if (lcbuf) {
2197             const struct lconv_offset *strings = lconv_strings;
2198             const struct lconv_offset *integers = lconv_integers;
2199             const char *ptr = (const char *) lcbuf;
2200
2201             while (strings->name) {
2202                 /* This string may be controlled by either LC_NUMERIC, or
2203                  * LC_MONETARY */
2204                 const bool is_utf8_locale =
2205 #  if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
2206                                         (isLC_NUMERIC_STRING(strings->name))
2207                                         ? is_numeric_utf8
2208                                         : is_monetary_utf8;
2209 #  elif defined(USE_LOCALE_NUMERIC)
2210                                         is_numeric_utf8;
2211 #  elif defined(USE_LOCALE_MONETARY)
2212                                         is_monetary_utf8;
2213 #  else
2214                                         FALSE;
2215 #  endif
2216
2217                 const char *value = *((const char **)(ptr + strings->offset));
2218
2219                 if (value && *value) {
2220                     const STRLEN value_len = strlen(value);
2221
2222                     /* We mark it as UTF-8 if a utf8 locale and is valid and
2223                      * variant under UTF-8 */
2224                     const bool is_utf8 = is_utf8_locale
2225                                      &&  is_utf8_non_invariant_string(
2226                                                                 (U8*) value,
2227                                                                 value_len);
2228                     (void) hv_store(RETVAL,
2229                                     strings->name,
2230                                     strlen(strings->name),
2231                                     newSVpvn_utf8(value, value_len, is_utf8),
2232                                     0);
2233             }
2234                 strings++;
2235             }
2236
2237             while (integers->name) {
2238                 const char value = *((const char *)(ptr + integers->offset));
2239
2240                 if (value != CHAR_MAX)
2241                     (void) hv_store(RETVAL, integers->name,
2242                                     strlen(integers->name), newSViv(value), 0);
2243                 integers++;
2244             }
2245         }
2246 #  if defined(USE_ITHREADS)                         \
2247    && defined(HAS_POSIX_2008_LOCALE)                \
2248    && defined(HAS_LOCALECONV_L)
2249         if (do_free) {
2250             freelocale(cur);
2251         }
2252 #  else
2253 #    ifdef TS_W32_BROKEN_LOCALECONV
2254         Perl_setlocale(LC_ALL, save_global);
2255
2256         _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
2257
2258         Perl_setlocale(LC_ALL, save_thread);
2259
2260         Safefree(save_global);
2261         Safefree(save_thread);
2262 #    endif
2263         LOCALE_UNLOCK_V;
2264 #  endif
2265         RESTORE_LC_NUMERIC();
2266 #endif  /* HAS_LOCALECONV */
2267     OUTPUT:
2268         RETVAL
2269
2270 char *
2271 setlocale(category, locale = 0)
2272         int             category
2273         const char *    locale
2274     PREINIT:
2275         char *          retval;
2276     CODE:
2277         retval = (char *) Perl_setlocale(category, locale);
2278         if (! retval) {
2279             XSRETURN_UNDEF;
2280         }
2281
2282         RETVAL = retval;
2283     OUTPUT:
2284         RETVAL
2285
2286 NV
2287 acos(x)
2288         NV              x
2289     ALIAS:
2290         acosh = 1
2291         asin = 2
2292         asinh = 3
2293         atan = 4
2294         atanh = 5
2295         cbrt = 6
2296         ceil = 7
2297         cosh = 8
2298         erf = 9
2299         erfc = 10
2300         exp2 = 11
2301         expm1 = 12
2302         floor = 13
2303         j0 = 14
2304         j1 = 15
2305         lgamma = 16
2306         log10 = 17
2307         log1p = 18
2308         log2 = 19
2309         logb = 20
2310         nearbyint = 21
2311         rint = 22
2312         round = 23
2313         sinh = 24
2314         tan = 25
2315         tanh = 26
2316         tgamma = 27
2317         trunc = 28
2318         y0 = 29
2319         y1 = 30
2320     CODE:
2321         PERL_UNUSED_VAR(x);
2322 #ifdef NV_NAN
2323         RETVAL = NV_NAN;
2324 #else
2325         RETVAL = 0;
2326 #endif
2327         switch (ix) {
2328         case 0:
2329             RETVAL = Perl_acos(x); /* C89 math */
2330             break;
2331         case 1:
2332 #ifdef c99_acosh
2333             RETVAL = c99_acosh(x);
2334 #else
2335             not_here("acosh");
2336 #endif
2337             break;
2338         case 2:
2339             RETVAL = Perl_asin(x); /* C89 math */
2340             break;
2341         case 3:
2342 #ifdef c99_asinh
2343             RETVAL = c99_asinh(x);
2344 #else
2345             not_here("asinh");
2346 #endif
2347             break;
2348         case 4:
2349             RETVAL = Perl_atan(x); /* C89 math */
2350             break;
2351         case 5:
2352 #ifdef c99_atanh
2353             RETVAL = c99_atanh(x);
2354 #else
2355             not_here("atanh");
2356 #endif
2357             break;
2358         case 6:
2359 #ifdef c99_cbrt
2360             RETVAL = c99_cbrt(x);
2361 #else
2362             not_here("cbrt");
2363 #endif
2364             break;
2365         case 7:
2366             RETVAL = Perl_ceil(x); /* C89 math */
2367             break;
2368         case 8:
2369             RETVAL = Perl_cosh(x); /* C89 math */
2370             break;
2371         case 9:
2372 #ifdef c99_erf
2373             RETVAL = c99_erf(x);
2374 #else
2375             not_here("erf");
2376 #endif
2377             break;
2378         case 10:
2379 #ifdef c99_erfc
2380             RETVAL = c99_erfc(x);
2381 #else
2382             not_here("erfc");
2383 #endif
2384             break;
2385         case 11:
2386 #ifdef c99_exp2
2387             RETVAL = c99_exp2(x);
2388 #else
2389             not_here("exp2");
2390 #endif
2391             break;
2392         case 12:
2393 #ifdef c99_expm1
2394             RETVAL = c99_expm1(x);
2395 #else
2396             not_here("expm1");
2397 #endif
2398             break;
2399         case 13:
2400             RETVAL = Perl_floor(x); /* C89 math */
2401             break;
2402         case 14:
2403 #ifdef bessel_j0
2404             RETVAL = bessel_j0(x);
2405 #else
2406             not_here("j0");
2407 #endif
2408             break;
2409         case 15:
2410 #ifdef bessel_j1
2411             RETVAL = bessel_j1(x);
2412 #else
2413             not_here("j1");
2414 #endif
2415             break;
2416         case 16:
2417         /* XXX Note: the lgamma modifies a global variable (signgam),
2418          * which is evil.  Some platforms have lgamma_r, which has
2419          * extra output parameter instead of the global variable. */
2420 #ifdef c99_lgamma
2421             RETVAL = c99_lgamma(x);
2422 #else
2423             not_here("lgamma");
2424 #endif
2425             break;
2426         case 17:
2427             RETVAL = Perl_log10(x); /* C89 math */
2428             break;
2429         case 18:
2430 #ifdef c99_log1p
2431             RETVAL = c99_log1p(x);
2432 #else
2433             not_here("log1p");
2434 #endif
2435             break;
2436         case 19:
2437 #ifdef c99_log2
2438             RETVAL = c99_log2(x);
2439 #else
2440             not_here("log2");
2441 #endif
2442             break;
2443         case 20:
2444 #ifdef c99_logb
2445             RETVAL = c99_logb(x);
2446 #elif defined(c99_log2) && FLT_RADIX == 2
2447             RETVAL = Perl_floor(c99_log2(PERL_ABS(x)));
2448 #else
2449             not_here("logb");
2450 #endif
2451             break;
2452         case 21:
2453 #ifdef c99_nearbyint
2454             RETVAL = c99_nearbyint(x);
2455 #else
2456             not_here("nearbyint");
2457 #endif
2458             break;
2459         case 22:
2460 #ifdef c99_rint
2461             RETVAL = c99_rint(x);
2462 #else
2463             not_here("rint");
2464 #endif
2465             break;
2466         case 23:
2467 #ifdef c99_round
2468             RETVAL = c99_round(x);
2469 #else
2470             not_here("round");
2471 #endif
2472             break;
2473         case 24:
2474             RETVAL = Perl_sinh(x); /* C89 math */
2475             break;
2476         case 25:
2477             RETVAL = Perl_tan(x); /* C89 math */
2478             break;
2479         case 26:
2480             RETVAL = Perl_tanh(x); /* C89 math */
2481             break;
2482         case 27:
2483 #ifdef c99_tgamma
2484             RETVAL = c99_tgamma(x);
2485 #else
2486             not_here("tgamma");
2487 #endif
2488             break;
2489         case 28:
2490 #ifdef c99_trunc
2491             RETVAL = c99_trunc(x);
2492 #else
2493             not_here("trunc");
2494 #endif
2495             break;
2496         case 29:
2497 #ifdef bessel_y0
2498             RETVAL = bessel_y0(x);
2499 #else
2500             not_here("y0");
2501 #endif
2502             break;
2503         case 30:
2504         default:
2505 #ifdef bessel_y1
2506             RETVAL = bessel_y1(x);
2507 #else
2508             not_here("y1");
2509 #endif
2510         }
2511     OUTPUT:
2512         RETVAL
2513
2514 IV
2515 fegetround()
2516     CODE:
2517 #ifdef HAS_FEGETROUND
2518         RETVAL = my_fegetround();
2519 #else
2520         RETVAL = -1;
2521         not_here("fegetround");
2522 #endif
2523     OUTPUT:
2524         RETVAL
2525
2526 IV
2527 fesetround(x)
2528         IV      x
2529     CODE:
2530 #ifdef HAS_FEGETROUND /* canary for fesetround */
2531         RETVAL = fesetround(x);
2532 #elif defined(HAS_FPGETROUND) /* canary for fpsetround */
2533         switch (x) {
2534         case FE_TONEAREST:  RETVAL = fpsetround(FP_RN); break;
2535         case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
2536         case FE_DOWNWARD:   RETVAL = fpsetround(FP_RM); break;
2537         case FE_UPWARD:     RETVAL = fpsetround(FP_RP); break;
2538         default: RETVAL = -1; break;
2539         }
2540 #elif defined(__osf__) /* Tru64 */
2541         switch (x) {
2542         case FE_TONEAREST:  RETVAL = write_rnd(FP_RND_RN); break;
2543         case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break;
2544         case FE_DOWNWARD:   RETVAL = write_rnd(FP_RND_RM); break;
2545         case FE_UPWARD:     RETVAL = write_rnd(FP_RND_RP); break;
2546         default: RETVAL = -1; break;
2547         }
2548 #else
2549         PERL_UNUSED_VAR(x);
2550         RETVAL = -1;
2551         not_here("fesetround");
2552 #endif
2553     OUTPUT:
2554         RETVAL
2555
2556 IV
2557 fpclassify(x)
2558         NV              x
2559     ALIAS:
2560         ilogb = 1
2561         isfinite = 2
2562         isinf = 3
2563         isnan = 4
2564         isnormal = 5
2565         lrint = 6
2566         lround = 7
2567         signbit = 8
2568     CODE:
2569         PERL_UNUSED_VAR(x);
2570         RETVAL = -1;
2571         switch (ix) {
2572         case 0:
2573 #ifdef c99_fpclassify
2574             RETVAL = c99_fpclassify(x);
2575 #else
2576             not_here("fpclassify");
2577 #endif
2578             break;
2579         case 1:
2580 #ifdef c99_ilogb
2581             RETVAL = c99_ilogb(x);
2582 #else
2583             not_here("ilogb");
2584 #endif
2585             break;
2586         case 2:
2587             RETVAL = Perl_isfinite(x);
2588             break;
2589         case 3:
2590             RETVAL = Perl_isinf(x);
2591             break;
2592         case 4:
2593             RETVAL = Perl_isnan(x);
2594             break;
2595         case 5:
2596 #ifdef c99_isnormal
2597             RETVAL = c99_isnormal(x);
2598 #else
2599             not_here("isnormal");
2600 #endif
2601             break;
2602         case 6:
2603 #ifdef c99_lrint
2604             RETVAL = c99_lrint(x);
2605 #else
2606             not_here("lrint");
2607 #endif
2608             break;
2609         case 7:
2610 #ifdef c99_lround
2611             RETVAL = c99_lround(x);
2612 #else
2613             not_here("lround");
2614 #endif
2615             break;
2616         case 8:
2617         default:
2618 #ifdef Perl_signbit
2619             RETVAL = Perl_signbit(x);
2620 #else
2621             RETVAL = (x < 0);
2622 #ifdef DOUBLE_IS_IEEE_FORMAT
2623             if (x == -0.0) {
2624               RETVAL = TRUE;
2625             }
2626 #endif
2627 #endif
2628             break;
2629         }
2630     OUTPUT:
2631         RETVAL
2632
2633 NV
2634 getpayload(nv)
2635         NV nv
2636     CODE:
2637 #ifdef DOUBLE_HAS_NAN
2638         RETVAL = S_getpayload(nv);
2639 #else
2640         PERL_UNUSED_VAR(nv);
2641         RETVAL = 0.0;
2642         not_here("getpayload");
2643 #endif
2644     OUTPUT:
2645         RETVAL
2646
2647 void
2648 setpayload(nv, payload)
2649         NV nv
2650         NV payload
2651     CODE:
2652 #ifdef DOUBLE_HAS_NAN
2653         S_setpayload(&nv, payload, FALSE);
2654 #else
2655         PERL_UNUSED_VAR(nv);
2656         PERL_UNUSED_VAR(payload);
2657         not_here("setpayload");
2658 #endif
2659     OUTPUT:
2660         nv
2661
2662 void
2663 setpayloadsig(nv, payload)
2664         NV nv
2665         NV payload
2666     CODE:
2667 #ifdef DOUBLE_HAS_NAN
2668         nv = NV_NAN;
2669         S_setpayload(&nv, payload, TRUE);
2670 #else
2671         PERL_UNUSED_VAR(nv);
2672         PERL_UNUSED_VAR(payload);
2673         not_here("setpayloadsig");
2674 #endif
2675     OUTPUT:
2676         nv
2677
2678 int
2679 issignaling(nv)
2680         NV nv
2681     CODE:
2682 #ifdef DOUBLE_HAS_NAN
2683         RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv);
2684 #else
2685         PERL_UNUSED_VAR(nv);
2686         RETVAL = 0.0;
2687         not_here("issignaling");
2688 #endif
2689     OUTPUT:
2690         RETVAL
2691
2692 NV
2693 copysign(x,y)
2694         NV              x
2695         NV              y
2696     ALIAS:
2697         fdim = 1
2698         fmax = 2
2699         fmin = 3
2700         fmod = 4
2701         hypot = 5
2702         isgreater = 6
2703         isgreaterequal = 7
2704         isless = 8
2705         islessequal = 9
2706         islessgreater = 10
2707         isunordered = 11
2708         nextafter = 12
2709         nexttoward = 13
2710         remainder = 14
2711     CODE:
2712         PERL_UNUSED_VAR(x);
2713         PERL_UNUSED_VAR(y);
2714 #ifdef NV_NAN
2715         RETVAL = NV_NAN;
2716 #else
2717         RETVAL = 0;
2718 #endif
2719         switch (ix) {
2720         case 0:
2721 #ifdef c99_copysign
2722             RETVAL = c99_copysign(x, y);
2723 #else
2724             not_here("copysign");
2725 #endif
2726             break;
2727         case 1:
2728 #ifdef c99_fdim
2729             RETVAL = c99_fdim(x, y);
2730 #else
2731             not_here("fdim");
2732 #endif
2733             break;
2734         case 2:
2735 #ifdef c99_fmax
2736             RETVAL = c99_fmax(x, y);
2737 #else
2738             not_here("fmax");
2739 #endif
2740             break;
2741         case 3:
2742 #ifdef c99_fmin
2743             RETVAL = c99_fmin(x, y);
2744 #else
2745             not_here("fmin");
2746 #endif
2747             break;
2748         case 4:
2749             RETVAL = Perl_fmod(x, y); /* C89 math */
2750             break;
2751         case 5:
2752 #ifdef c99_hypot
2753             RETVAL = c99_hypot(x, y);
2754 #else
2755             not_here("hypot");
2756 #endif
2757             break;
2758         case 6:
2759 #ifdef c99_isgreater
2760             RETVAL = c99_isgreater(x, y);
2761 #else
2762             not_here("isgreater");
2763 #endif
2764             break;
2765         case 7:
2766 #ifdef c99_isgreaterequal
2767             RETVAL = c99_isgreaterequal(x, y);
2768 #else
2769             not_here("isgreaterequal");
2770 #endif
2771             break;
2772         case 8:
2773 #ifdef c99_isless
2774             RETVAL = c99_isless(x, y);
2775 #else
2776             not_here("isless");
2777 #endif
2778             break;
2779         case 9:
2780 #ifdef c99_islessequal
2781             RETVAL = c99_islessequal(x, y);
2782 #else
2783             not_here("islessequal");
2784 #endif
2785             break;
2786         case 10:
2787 #ifdef c99_islessgreater
2788             RETVAL = c99_islessgreater(x, y);
2789 #else
2790             not_here("islessgreater");
2791 #endif
2792             break;
2793         case 11:
2794 #ifdef c99_isunordered
2795             RETVAL = c99_isunordered(x, y);
2796 #else
2797             not_here("isunordered");
2798 #endif
2799             break;
2800         case 12:
2801 #ifdef c99_nextafter
2802             RETVAL = c99_nextafter(x, y);
2803 #else
2804             not_here("nextafter");
2805 #endif
2806             break;
2807         case 13:
2808 #ifdef c99_nexttoward
2809             RETVAL = c99_nexttoward(x, y);
2810 #else
2811             not_here("nexttoward");
2812 #endif
2813             break;
2814         case 14:
2815         default:
2816 #ifdef c99_remainder
2817           RETVAL = c99_remainder(x, y);
2818 #else
2819           not_here("remainder");
2820 #endif
2821             break;
2822         }
2823         OUTPUT:
2824             RETVAL
2825
2826 void
2827 frexp(x)
2828         NV              x
2829     PPCODE:
2830         int expvar;
2831         /* (We already know stack is long enough.) */
2832         PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2833         PUSHs(sv_2mortal(newSViv(expvar)));
2834
2835 NV
2836 ldexp(x,exp)
2837         NV              x
2838         int             exp
2839     CODE:
2840         RETVAL = Perl_ldexp(x, exp);
2841     OUTPUT:
2842         RETVAL
2843
2844 void
2845 modf(x)
2846         NV              x
2847     PPCODE:
2848         NV intvar;
2849         /* (We already know stack is long enough.) */
2850         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2851         PUSHs(sv_2mortal(newSVnv(intvar)));
2852
2853 void
2854 remquo(x,y)
2855         NV              x
2856         NV              y
2857     PPCODE:
2858 #ifdef c99_remquo
2859         int intvar;
2860         PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2861         PUSHs(sv_2mortal(newSVnv(intvar)));
2862 #else
2863         PERL_UNUSED_VAR(x);
2864         PERL_UNUSED_VAR(y);
2865         not_here("remquo");
2866 #endif
2867
2868 NV
2869 scalbn(x,y)
2870         NV              x
2871         IV              y
2872     CODE:
2873 #ifdef c99_scalbn
2874         RETVAL = c99_scalbn(x, y);
2875 #else
2876         PERL_UNUSED_VAR(x);
2877         PERL_UNUSED_VAR(y);
2878         RETVAL = NV_NAN;
2879         not_here("scalbn");
2880 #endif
2881     OUTPUT:
2882         RETVAL
2883
2884 NV
2885 fma(x,y,z)
2886         NV              x
2887         NV              y
2888         NV              z
2889     CODE:
2890 #ifdef c99_fma
2891         RETVAL = c99_fma(x, y, z);
2892 #else
2893         PERL_UNUSED_VAR(x);
2894         PERL_UNUSED_VAR(y);
2895         PERL_UNUSED_VAR(z);
2896         not_here("fma");
2897 #endif
2898     OUTPUT:
2899         RETVAL
2900
2901 NV
2902 nan(payload = 0)
2903         NV payload
2904     CODE:
2905 #ifdef NV_NAN
2906         /* If no payload given, just return the default NaN.
2907          * This makes a difference in platforms where the default
2908          * NaN is not all zeros. */
2909         if (items == 0) {
2910           RETVAL = NV_NAN;
2911         } else {
2912           S_setpayload(&RETVAL, payload, FALSE);
2913         }
2914 #elif defined(c99_nan)
2915         {
2916           STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload);
2917           if ((IV)elen == -1) {
2918 #ifdef NV_NAN
2919             RETVAL = NV_NAN;
2920 #else
2921             RETVAL = 0.0;
2922             not_here("nan");
2923 #endif
2924           } else {
2925             RETVAL = c99_nan(PL_efloatbuf);
2926           }
2927         }
2928 #else
2929         not_here("nan");
2930 #endif
2931     OUTPUT:
2932         RETVAL
2933
2934 NV
2935 jn(x,y)
2936         IV              x
2937         NV              y
2938     ALIAS:
2939         yn = 1
2940     CODE:
2941 #ifdef NV_NAN
2942         RETVAL = NV_NAN;
2943 #else
2944         RETVAL = 0;
2945 #endif
2946         switch (ix) {
2947         case 0:
2948 #ifdef bessel_jn
2949           RETVAL = bessel_jn(x, y);
2950 #else
2951           PERL_UNUSED_VAR(x);
2952           PERL_UNUSED_VAR(y);
2953           not_here("jn");
2954 #endif
2955             break;
2956         case 1:
2957         default:
2958 #ifdef bessel_yn
2959           RETVAL = bessel_yn(x, y);
2960 #else
2961           PERL_UNUSED_VAR(x);
2962           PERL_UNUSED_VAR(y);
2963           not_here("yn");
2964 #endif
2965             break;
2966         }
2967     OUTPUT:
2968         RETVAL
2969
2970 SysRet
2971 sigaction(sig, optaction, oldaction = 0)
2972         int                     sig
2973         SV *                    optaction
2974         POSIX::SigAction        oldaction
2975     CODE:
2976 #if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__))
2977         RETVAL = not_here("sigaction");
2978 #else
2979 # This code is really grody because we are trying to make the signal
2980 # interface look beautiful, which is hard.
2981
2982         {
2983             dVAR;
2984             POSIX__SigAction action;
2985             GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
2986             struct sigaction act;
2987             struct sigaction oact;
2988             sigset_t sset;
2989             SV *osset_sv;
2990             sigset_t osset;
2991             POSIX__SigSet sigset;
2992             SV** svp;
2993             SV** sigsvp;
2994
2995             if (sig < 0) {
2996                 croak("Negative signals are not allowed");
2997             }
2998
2999             if (sig == 0 && SvPOK(ST(0))) {
3000                 const char *s = SvPVX_const(ST(0));
3001                 int i = whichsig(s);
3002
3003                 if (i < 0 && memBEGINs(s, SvCUR(ST(0)), "SIG"))
3004                     i = whichsig(s + 3);
3005                 if (i < 0) {
3006                     if (ckWARN(WARN_SIGNAL))
3007                         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3008                                     "No such signal: SIG%s", s);
3009                     XSRETURN_UNDEF;
3010                 }
3011                 else
3012                     sig = i;
3013             }
3014 #ifdef NSIG
3015             if (sig > NSIG) { /* NSIG - 1 is still okay. */
3016                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3017                             "No such signal: %d", sig);
3018                 XSRETURN_UNDEF;
3019             }
3020 #endif
3021             sigsvp = hv_fetch(GvHVn(siggv),
3022                               PL_sig_name[sig],
3023                               strlen(PL_sig_name[sig]),
3024                               TRUE);
3025
3026             /* Check optaction and set action */
3027             if(SvTRUE(optaction)) {
3028                 if(sv_isa(optaction, "POSIX::SigAction"))
3029                         action = (HV*)SvRV(optaction);
3030                 else
3031                         croak("action is not of type POSIX::SigAction");
3032             }
3033             else {
3034                 action=0;
3035             }
3036
3037             /* sigaction() is supposed to look atomic. In particular, any
3038              * signal handler invoked during a sigaction() call should
3039              * see either the old or the new disposition, and not something
3040              * in between. We use sigprocmask() to make it so.
3041              */
3042             sigfillset(&sset);
3043             RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
3044             if(RETVAL == -1)
3045                XSRETURN_UNDEF;
3046             ENTER;
3047             /* Restore signal mask no matter how we exit this block. */
3048             osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
3049             SAVEFREESV( osset_sv );
3050             SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
3051
3052             RETVAL=-1; /* In case both oldaction and action are 0. */
3053
3054             /* Remember old disposition if desired. */
3055             if (oldaction) {
3056                 int safe;
3057
3058                 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
3059                 if(!svp)
3060                     croak("Can't supply an oldaction without a HANDLER");
3061                 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
3062                         sv_setsv(*svp, *sigsvp);
3063                 }
3064                 else {
3065                         sv_setpvs(*svp, "DEFAULT");
3066                 }
3067                 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
3068                 if(RETVAL == -1) {
3069                    LEAVE;
3070                    XSRETURN_UNDEF;
3071                 }
3072                 /* Get back the mask. */
3073                 svp = hv_fetchs(oldaction, "MASK", TRUE);
3074                 if (sv_isa(*svp, "POSIX::SigSet")) {
3075                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3076                 }
3077                 else {
3078                     sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
3079                                                           sizeof(sigset_t),
3080                                                           "POSIX::SigSet");
3081                 }
3082                 *sigset = oact.sa_mask;
3083
3084                 /* Get back the flags. */
3085                 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
3086                 sv_setiv(*svp, oact.sa_flags);
3087
3088                 /* Get back whether the old handler used safe signals;
3089                  * i.e. it used Perl_csighandler[13] rather than
3090                  * Perl_sighandler[13]
3091                  */
3092                 safe =
3093 #ifdef SA_SIGINFO
3094                     (oact.sa_flags & SA_SIGINFO)
3095                         ? (  oact.sa_sigaction == PL_csighandler3p
3096 #ifdef PERL_USE_3ARG_SIGHANDLER
3097                           || oact.sa_sigaction == PL_csighandlerp
3098 #endif
3099                           )
3100                         :
3101 #endif
3102                            (  oact.sa_handler   == PL_csighandler1p
3103 #ifndef PERL_USE_3ARG_SIGHANDLER
3104                           || oact.sa_handler   == PL_csighandlerp
3105 #endif
3106                            );
3107
3108                 svp = hv_fetchs(oldaction, "SAFE", TRUE);
3109                 sv_setiv(*svp, safe);
3110             }
3111
3112             if (action) {
3113                 int safe;
3114
3115                 /* Set up any desired flags. */
3116                 svp = hv_fetchs(action, "FLAGS", FALSE);
3117                 act.sa_flags = svp ? SvIV(*svp) : 0;
3118
3119                 /* Safe signals use "csighandler", which vectors through the
3120                    PL_sighandlerp pointer when it's safe to do so.
3121                    (BTW, "csighandler" is very different from "sighandler".) */
3122                 svp = hv_fetchs(action, "SAFE", FALSE);
3123                 safe = *svp && SvTRUE(*svp);
3124 #ifdef SA_SIGINFO
3125                 if (act.sa_flags & SA_SIGINFO) {
3126                     /* 3-arg handler */
3127                     act.sa_sigaction =
3128                             safe ? PL_csighandler3p : PL_sighandler3p;
3129                 }
3130                 else
3131 #endif
3132                 {
3133                     /* 1-arg handler */
3134                     act.sa_handler =
3135                             safe ? PL_csighandler1p : PL_sighandler1p;
3136                 }
3137
3138                 /* Vector new Perl handler through %SIG.
3139                    (The core signal handlers read %SIG to dispatch.) */
3140                 svp = hv_fetchs(action, "HANDLER", FALSE);
3141                 if (!svp)
3142                     croak("Can't supply an action without a HANDLER");
3143                 sv_setsv(*sigsvp, *svp);
3144
3145                 /* This call actually calls sigaction() with almost the
3146                    right settings, including appropriate interpretation
3147                    of DEFAULT and IGNORE.  However, why are we doing
3148                    this when we're about to do it again just below?  XXX */
3149                 SvSETMAGIC(*sigsvp);
3150
3151                 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
3152                 if(SvPOK(*svp)) {
3153                         const char *s=SvPVX_const(*svp);
3154                         if(strEQ(s,"IGNORE")) {
3155                                 act.sa_handler = SIG_IGN;
3156                         }
3157                         else if(strEQ(s,"DEFAULT")) {
3158                                 act.sa_handler = SIG_DFL;
3159                         }
3160                 }
3161
3162                 /* Set up any desired mask. */
3163                 svp = hv_fetchs(action, "MASK", FALSE);
3164                 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
3165                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3166                     act.sa_mask = *sigset;
3167                 }
3168                 else
3169                     sigemptyset(& act.sa_mask);
3170
3171                 /* Don't worry about cleaning up *sigsvp if this fails,
3172                  * because that means we tried to disposition a
3173                  * nonblockable signal, in which case *sigsvp is
3174                  * essentially meaningless anyway.
3175                  */
3176                 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
3177                 if(RETVAL == -1) {
3178                     LEAVE;
3179                     XSRETURN_UNDEF;
3180                 }
3181             }
3182
3183             LEAVE;
3184         }
3185 #endif
3186     OUTPUT:
3187         RETVAL
3188
3189 SysRet
3190 sigpending(sigset)
3191         POSIX::SigSet           sigset
3192     ALIAS:
3193         sigsuspend = 1
3194     CODE:
3195 #ifdef __amigaos4__
3196         RETVAL = not_here("sigpending");
3197 #else
3198         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
3199 #endif
3200     OUTPUT:
3201         RETVAL
3202     CLEANUP:
3203     PERL_ASYNC_CHECK();
3204
3205 SysRet
3206 sigprocmask(how, sigset, oldsigset = 0)
3207         int                     how
3208         POSIX::SigSet           sigset = NO_INIT
3209         POSIX::SigSet           oldsigset = NO_INIT
3210 INIT:
3211         if (! SvOK(ST(1))) {
3212             sigset = NULL;
3213         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
3214             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
3215         } else {
3216             croak("sigset is not of type POSIX::SigSet");
3217         }
3218
3219         if (items < 3 || ! SvOK(ST(2))) {
3220             oldsigset = NULL;
3221         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
3222             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
3223         } else {
3224             croak("oldsigset is not of type POSIX::SigSet");
3225         }
3226
3227 void
3228 _exit(status)
3229         int             status
3230
3231 SysRet
3232 dup2(fd1, fd2)
3233         int             fd1
3234         int             fd2
3235     CODE:
3236         if (fd1 >= 0 && fd2 >= 0) {
3237 #ifdef WIN32
3238             /* RT #98912 - More Microsoft muppetry - failing to
3239                actually implemented the well known documented POSIX
3240                behaviour for a POSIX API.
3241                http://msdn.microsoft.com/en-us/library/8syseb29.aspx  */
3242             RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
3243 #else
3244             RETVAL = dup2(fd1, fd2);
3245 #endif
3246         } else {
3247             SETERRNO(EBADF,RMS_IFI);
3248             RETVAL = -1;
3249         }
3250     OUTPUT:
3251         RETVAL
3252
3253 SV *
3254 lseek(fd, offset, whence)
3255         POSIX::Fd       fd
3256         Off_t           offset
3257         int             whence
3258     CODE:
3259         {
3260               Off_t pos = PerlLIO_lseek(fd, offset, whence);
3261               RETVAL = sizeof(Off_t) > sizeof(IV)
3262                 ? newSVnv((NV)pos) : newSViv((IV)pos);
3263         }
3264     OUTPUT:
3265         RETVAL
3266
3267 void
3268 nice(incr)
3269         int             incr
3270     PPCODE:
3271         errno = 0;
3272         if ((incr = nice(incr)) != -1 || errno == 0) {
3273             if (incr == 0)
3274                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
3275             else
3276                 XPUSHs(sv_2mortal(newSViv(incr)));
3277         }
3278
3279 void
3280 pipe()
3281     PPCODE:
3282         int fds[2];
3283         if (pipe(fds) != -1) {
3284             EXTEND(SP,2);
3285             PUSHs(sv_2mortal(newSViv(fds[0])));
3286             PUSHs(sv_2mortal(newSViv(fds[1])));
3287         }
3288
3289 SysRet
3290 read(fd, buffer, nbytes)
3291     PREINIT:
3292         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3293     INPUT:
3294         POSIX::Fd       fd
3295         size_t          nbytes
3296         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
3297     CLEANUP:
3298         if (RETVAL >= 0) {
3299             SvCUR_set(sv_buffer, RETVAL);
3300             SvPOK_only(sv_buffer);
3301             *SvEND(sv_buffer) = '\0';
3302             SvTAINTED_on(sv_buffer);
3303         }
3304
3305 SysRet
3306 setpgid(pid, pgid)
3307         pid_t           pid
3308         pid_t           pgid
3309
3310 pid_t
3311 setsid()
3312
3313 pid_t
3314 tcgetpgrp(fd)
3315         POSIX::Fd       fd
3316
3317 SysRet
3318 tcsetpgrp(fd, pgrp_id)
3319         POSIX::Fd       fd
3320         pid_t           pgrp_id
3321
3322 void
3323 uname()
3324     PPCODE:
3325 #ifdef HAS_UNAME
3326         struct utsname buf;
3327         if (uname(&buf) >= 0) {
3328             EXTEND(SP, 5);
3329             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
3330             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
3331             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
3332             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
3333             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
3334         }
3335 #else
3336         uname((char *) 0); /* A stub to call not_here(). */
3337 #endif
3338
3339 SysRet
3340 write(fd, buffer, nbytes)
3341         POSIX::Fd       fd
3342         char *          buffer
3343         size_t          nbytes
3344
3345 void
3346 abort()
3347
3348 #ifdef I_WCHAR
3349 #  include <wchar.h>
3350 #endif
3351
3352 int
3353 mblen(s, n)
3354         char *          s
3355         size_t          n
3356     PREINIT:
3357 #if defined(USE_ITHREADS) && defined(HAS_MBRLEN)
3358         mbstate_t ps;
3359 #endif
3360     CODE:
3361 #if defined(USE_ITHREADS) && defined(HAS_MBRLEN)
3362         memset(&ps, 0, sizeof(ps)); /* Initialize state */
3363         RETVAL = mbrlen(s, n, &ps); /* Prefer reentrant version */
3364 #else
3365         /* This might prevent some races, but locales can be switched out
3366          * without locking, so this isn't a cure all */
3367         LOCALE_LOCK;
3368
3369         RETVAL = mblen(s, n);
3370         LOCALE_UNLOCK;
3371 #endif
3372     OUTPUT:
3373         RETVAL
3374
3375 size_t
3376 mbstowcs(s, pwcs, n)
3377         wchar_t *       s
3378         char *          pwcs
3379         size_t          n
3380
3381 int
3382 mbtowc(pwc, s, n)
3383         wchar_t *       pwc
3384         char *          s
3385         size_t          n
3386     PREINIT:
3387 #if defined(USE_ITHREADS) && defined(HAS_MBRTOWC)
3388         mbstate_t ps;
3389 #endif
3390     CODE:
3391 #if defined(USE_ITHREADS) && defined(HAS_MBRTOWC)
3392         memset(&ps, 0, sizeof(ps));;
3393         PERL_UNUSED_RESULT(mbrtowc(pwc, NULL, 0, &ps));/* Reset any shift state */
3394         errno = 0;
3395         RETVAL = mbrtowc(pwc, s, n, &ps);   /* Prefer reentrant version */
3396 #else
3397         RETVAL = mbtowc(pwc, s, n);
3398 #endif
3399     OUTPUT:
3400         RETVAL
3401
3402 int
3403 wcstombs(s, pwcs, n)
3404         char *          s
3405         wchar_t *       pwcs
3406         size_t          n
3407
3408 int
3409 wctomb(s, wchar)
3410         char *          s
3411         wchar_t         wchar
3412
3413 int
3414 strcoll(s1, s2)
3415         char *          s1
3416         char *          s2
3417
3418 void
3419 strtod(str)
3420         char *          str
3421     PREINIT:
3422         double num;
3423         char *unparsed;
3424     PPCODE:
3425         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3426         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3427         num = strtod(str, &unparsed);
3428         RESTORE_LC_NUMERIC();
3429         PUSHs(sv_2mortal(newSVnv(num)));
3430         if (GIMME_V == G_ARRAY) {
3431             EXTEND(SP, 1);
3432             if (unparsed)
3433                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3434             else
3435                 PUSHs(&PL_sv_undef);
3436         }
3437
3438 #ifdef HAS_STRTOLD
3439
3440 void
3441 strtold(str)
3442         char *          str
3443     PREINIT:
3444         long double num;
3445         char *unparsed;
3446     PPCODE:
3447         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3448         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3449         num = strtold(str, &unparsed);
3450         RESTORE_LC_NUMERIC();
3451         PUSHs(sv_2mortal(newSVnv(num)));
3452         if (GIMME_V == G_ARRAY) {
3453             EXTEND(SP, 1);
3454             if (unparsed)
3455                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3456             else
3457                 PUSHs(&PL_sv_undef);
3458         }
3459
3460 #endif
3461
3462 void
3463 strtol(str, base = 0)
3464         char *          str
3465         int             base
3466     PREINIT:
3467         long num;
3468         char *unparsed;
3469     PPCODE:
3470         if (base == 0 || inRANGE(base, 2, 36)) {
3471             num = strtol(str, &unparsed, base);
3472 #if IVSIZE < LONGSIZE
3473             if (num < IV_MIN || num > IV_MAX)
3474                 PUSHs(sv_2mortal(newSVnv((double)num)));
3475             else
3476 #endif
3477                 PUSHs(sv_2mortal(newSViv((IV)num)));
3478             if (GIMME_V == G_ARRAY) {
3479                 EXTEND(SP, 1);
3480                 if (unparsed)
3481                     PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3482                 else
3483                     PUSHs(&PL_sv_undef);
3484             }
3485         } else {
3486             SETERRNO(EINVAL, LIB_INVARG);
3487             PUSHs(&PL_sv_undef);
3488             if (GIMME_V == G_ARRAY) {
3489                EXTEND(SP, 1);
3490                PUSHs(&PL_sv_undef);
3491             }
3492         }
3493
3494 void
3495 strtoul(str, base = 0)
3496         const char *    str
3497         int             base
3498     PREINIT:
3499         unsigned long num;
3500         char *unparsed = NULL;
3501     PPCODE:
3502         PERL_UNUSED_VAR(str);
3503         PERL_UNUSED_VAR(base);
3504         if (base == 0 || inRANGE(base, 2, 36)) {
3505             num = strtoul(str, &unparsed, base);
3506 #if IVSIZE <= LONGSIZE
3507             if (num > IV_MAX)
3508                 PUSHs(sv_2mortal(newSVnv((double)num)));
3509             else
3510 #endif
3511                 PUSHs(sv_2mortal(newSViv((IV)num)));
3512             if (GIMME_V == G_ARRAY) {
3513                 EXTEND(SP, 1);
3514                 if (unparsed)
3515                     PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3516                 else
3517                   PUSHs(&PL_sv_undef);
3518             }
3519         } else {
3520             SETERRNO(EINVAL, LIB_INVARG);
3521             PUSHs(&PL_sv_undef);
3522             if (GIMME_V == G_ARRAY) {
3523                EXTEND(SP, 1);
3524                PUSHs(&PL_sv_undef);
3525             }
3526         }
3527
3528 void
3529 strxfrm(src)
3530         SV *            src
3531     CODE:
3532         {
3533           STRLEN srclen;
3534           STRLEN dstlen;
3535           STRLEN buflen;
3536           char *p = SvPV(src,srclen);
3537           srclen++;
3538           buflen = srclen * 4 + 1;
3539           ST(0) = sv_2mortal(newSV(buflen));
3540           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen);
3541           if (dstlen >= buflen) {
3542               dstlen++;
3543               SvGROW(ST(0), dstlen);
3544               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
3545               dstlen--;
3546           }
3547           SvCUR_set(ST(0), dstlen);
3548             SvPOK_only(ST(0));
3549         }
3550
3551 SysRet
3552 mkfifo(filename, mode)
3553         char *          filename
3554         Mode_t          mode
3555     ALIAS:
3556         access = 1
3557     CODE:
3558         if(ix) {
3559             RETVAL = access(filename, mode);
3560         } else {
3561             TAINT_PROPER("mkfifo");
3562             RETVAL = mkfifo(filename, mode);
3563         }
3564     OUTPUT:
3565         RETVAL
3566
3567 SysRet
3568 tcdrain(fd)
3569         POSIX::Fd       fd
3570     ALIAS:
3571         close = 1
3572         dup = 2
3573     CODE:
3574         if (fd >= 0) {
3575             RETVAL = ix == 1 ? close(fd)
3576               : (ix < 1 ? tcdrain(fd) : dup(fd));
3577         } else {
3578             SETERRNO(EBADF,RMS_IFI);
3579             RETVAL = -1;
3580         }
3581     OUTPUT:
3582         RETVAL
3583
3584
3585 SysRet
3586 tcflow(fd, action)
3587         POSIX::Fd       fd
3588         int             action
3589     ALIAS:
3590         tcflush = 1
3591         tcsendbreak = 2
3592     CODE:
3593         if (action >= 0) {
3594             RETVAL = ix == 1 ? tcflush(fd, action)
3595               : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
3596         } else {
3597             SETERRNO(EINVAL,LIB_INVARG);
3598             RETVAL = -1;
3599         }
3600     OUTPUT:
3601         RETVAL
3602
3603 void
3604 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
3605         int             sec
3606         int             min
3607         int             hour
3608         int             mday
3609         int             mon
3610         int             year
3611         int             wday
3612         int             yday
3613         int             isdst
3614     ALIAS:
3615         mktime = 1
3616     PPCODE:
3617         {
3618             dXSTARG;
3619             struct tm mytm;
3620             init_tm(&mytm);     /* XXX workaround - see init_tm() in core util.c */
3621             mytm.tm_sec = sec;
3622             mytm.tm_min = min;
3623             mytm.tm_hour = hour;
3624             mytm.tm_mday = mday;
3625             mytm.tm_mon = mon;
3626             mytm.tm_year = year;
3627             mytm.tm_wday = wday;
3628             mytm.tm_yday = yday;
3629             mytm.tm_isdst = isdst;
3630             if (ix) {
3631                 const time_t result = mktime(&mytm);
3632                 if (result == (time_t)-1)
3633                     SvOK_off(TARG);
3634                 else if (result == 0)
3635                     sv_setpvs(TARG, "0 but true");
3636                 else
3637                     sv_setiv(TARG, (IV)result);
3638             } else {
3639                 sv_setpv(TARG, asctime(&mytm));
3640             }
3641             ST(0) = TARG;
3642             XSRETURN(1);
3643         }
3644
3645 long
3646 clock()
3647
3648 char *
3649 ctime(time)
3650         Time_t          &time
3651
3652 void
3653 times()
3654         PPCODE:
3655         struct tms tms;
3656         clock_t realtime;
3657         realtime = times( &tms );
3658         EXTEND(SP,5);
3659         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
3660         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
3661         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
3662         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
3663         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
3664
3665 double
3666 difftime(time1, time2)
3667         Time_t          time1
3668         Time_t          time2
3669
3670 #XXX: if $xsubpp::WantOptimize is always the default
3671 #     sv_setpv(TARG, ...) could be used rather than
3672 #     ST(0) = sv_2mortal(newSVpv(...))
3673 void
3674 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
3675         SV *            fmt
3676         int             sec
3677         int             min
3678         int             hour
3679         int             mday
3680         int             mon
3681         int             year
3682         int             wday
3683         int             yday
3684         int             isdst
3685     CODE:
3686         {
3687             char *buf;
3688             SV *sv;
3689
3690             /* allowing user-supplied (rather than literal) formats
3691              * is normally frowned upon as a potential security risk;
3692              * but this is part of the API so we have to allow it */
3693             GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
3694             buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
3695             GCC_DIAG_RESTORE_STMT;
3696             sv = sv_newmortal();
3697             if (buf) {
3698                 STRLEN len = strlen(buf);
3699                 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL);
3700                 if (       SvUTF8(fmt)
3701                     || (   is_utf8_non_invariant_string((U8*) buf, len)
3702 #ifdef USE_LOCALE_TIME
3703                         && _is_cur_LC_category_utf8(LC_TIME)
3704 #else   /* If can't check directly, at least can see if script is consistent,
3705            under UTF-8, which gives us an extra measure of confidence. */
3706
3707                         && isSCRIPT_RUN((const U8 *) buf,
3708                                         (const U8 *) buf + len,
3709                                         TRUE) /* Means assume UTF-8 */
3710 #endif
3711                 )) {
3712                     SvUTF8_on(sv);
3713                 }
3714             }
3715             else {  /* We can't distinguish between errors and just an empty
3716                      * return; in all cases just return an empty string */
3717                 SvUPGRADE(sv, SVt_PV);
3718                 SvPV_set(sv, (char *) "");
3719                 SvPOK_on(sv);
3720                 SvCUR_set(sv, 0);
3721                 SvLEN_set(sv, 0);   /* Won't attempt to free the string when sv
3722                                        gets destroyed */
3723             }
3724             ST(0) = sv;
3725         }
3726
3727 void
3728 tzset()
3729   PPCODE:
3730     my_tzset(aTHX);
3731
3732 void
3733 tzname()
3734     PPCODE:
3735         EXTEND(SP,2);
3736         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
3737         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
3738
3739 char *
3740 ctermid(s = 0)
3741         char *          s = 0;
3742     CODE:
3743 #ifdef HAS_CTERMID_R
3744         s = (char *) safemalloc((size_t) L_ctermid);
3745 #endif
3746         RETVAL = ctermid(s);
3747     OUTPUT:
3748         RETVAL
3749     CLEANUP:
3750 #ifdef HAS_CTERMID_R
3751         Safefree(s);
3752 #endif
3753
3754 char *
3755 cuserid(s = 0)
3756         char *          s = 0;
3757     CODE:
3758 #ifdef HAS_CUSERID
3759   RETVAL = cuserid(s);
3760 #else
3761   PERL_UNUSED_VAR(s);
3762   RETVAL = 0;
3763   not_here("cuserid");
3764 #endif
3765     OUTPUT:
3766   RETVAL
3767
3768 SysRetLong
3769 fpathconf(fd, name)
3770         POSIX::Fd       fd
3771         int             name
3772
3773 SysRetLong
3774 pathconf(filename, name)
3775         char *          filename
3776         int             name
3777
3778 SysRet
3779 pause()
3780     CLEANUP:
3781     PERL_ASYNC_CHECK();
3782
3783 unsigned int
3784 sleep(seconds)
3785         unsigned int    seconds
3786     CODE:
3787         RETVAL = PerlProc_sleep(seconds);
3788     OUTPUT:
3789         RETVAL
3790
3791 SysRet
3792 setgid(gid)
3793         Gid_t           gid
3794
3795 SysRet
3796 setuid(uid)
3797         Uid_t           uid
3798
3799 SysRetLong
3800 sysconf(name)
3801         int             name
3802
3803 char *
3804 ttyname(fd)
3805         POSIX::Fd       fd
3806
3807 void
3808 getcwd()
3809     PPCODE:
3810       {
3811         dXSTARG;
3812         getcwd_sv(TARG);
3813         XSprePUSH; PUSHTARG;
3814       }
3815
3816 SysRet
3817 lchown(uid, gid, path)
3818        Uid_t           uid
3819        Gid_t           gid
3820        char *          path
3821     CODE:
3822 #ifdef HAS_LCHOWN
3823        /* yes, the order of arguments is different,
3824         * but consistent with CORE::chown() */
3825        RETVAL = lchown(path, uid, gid);
3826 #else
3827        PERL_UNUSED_VAR(uid);
3828        PERL_UNUSED_VAR(gid);
3829        PERL_UNUSED_VAR(path);
3830        RETVAL = not_here("lchown");
3831 #endif
3832     OUTPUT:
3833        RETVAL