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