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