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