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