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