ext/POSIX/POSIX.xs

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