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