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