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