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