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