ext/POSIX/POSIX.xs

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