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