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