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