ext/POSIX/POSIX.xs

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