This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
POSIX::localconv(): Prefer localeconv_l()
[perl5.git] / ext / POSIX / POSIX.xs
1 #define PERL_EXT_POSIX
2 #define PERL_EXT
3
4 #ifdef NETWARE
5         #define _POSIX_
6         /*
7          * Ideally this should be somewhere down in the includes
8          * but putting it in other places is giving compiler errors.
9          * Also here I am unable to check for HAS_UNAME since it wouldn't have
10          * yet come into the file at this stage - sgp 18th Oct 2000
11          */
12         #include <sys/utsname.h>
13 #endif  /* NETWARE */
14
15 #define PERL_NO_GET_CONTEXT
16
17 #include "EXTERN.h"
18 #define PERLIO_NOT_STDIO 1
19 #include "perl.h"
20 #include "XSUB.h"
21
22 static int not_here(const char *s);
23
24 #if defined(PERL_IMPLICIT_SYS)
25 #  undef signal
26 #  undef open
27 #  undef setmode
28 #  define open PerlLIO_open3
29 #endif
30 #include <ctype.h>
31 #ifdef I_DIRENT    /* XXX maybe better to just rely on perl.h? */
32 #include <dirent.h>
33 #endif
34 #include <errno.h>
35 #ifdef WIN32
36 #include <sys/errno2.h>
37 #endif
38 #include <float.h>
39 #ifdef I_FENV
40 #if !(defined(__vax__) && defined(__NetBSD__))
41 #include <fenv.h>
42 #endif
43 #endif
44 #include <limits.h>
45 #include <locale.h>
46 #include <math.h>
47 #ifdef I_PWD
48 #include <pwd.h>
49 #endif
50 #include <setjmp.h>
51 #include <signal.h>
52 #include <stdarg.h>
53 #include <stddef.h>
54
55 #ifdef I_UNISTD
56 #include <unistd.h>
57 #endif
58
59 #ifdef I_SYS_TIME
60 # include <sys/time.h>
61 #endif
62
63 #ifdef I_SYS_RESOURCE
64 # include <sys/resource.h>
65 #endif
66
67 #if defined(USE_QUADMATH) && defined(I_QUADMATH)
68
69 #  undef M_E
70 #  undef M_LOG2E
71 #  undef M_LOG10E
72 #  undef M_LN2
73 #  undef M_LN10
74 #  undef M_PI
75 #  undef M_PI_2
76 #  undef M_PI_4
77 #  undef M_1_PI
78 #  undef M_2_PI
79 #  undef M_2_SQRTPI
80 #  undef M_SQRT2
81 #  undef M_SQRT1_2
82
83 #  define M_E        M_Eq
84 #  define M_LOG2E    M_LOG2Eq
85 #  define M_LOG10E   M_LOG10Eq
86 #  define M_LN2      M_LN2q
87 #  define M_LN10     M_LN10q
88 #  define M_PI       M_PIq
89 #  define M_PI_2     M_PI_2q
90 #  define M_PI_4     M_PI_4q
91 #  define M_1_PI     M_1_PIq
92 #  define M_2_PI     M_2_PIq
93 #  define M_2_SQRTPI M_2_SQRTPIq
94 #  define M_SQRT2    M_SQRT2q
95 #  define M_SQRT1_2  M_SQRT1_2q
96
97 #else
98
99 #  ifdef USE_LONG_DOUBLE
100 #    undef M_E
101 #    undef M_LOG2E
102 #    undef M_LOG10E
103 #    undef M_LN2
104 #    undef M_LN10
105 #    undef M_PI
106 #    undef M_PI_2
107 #    undef M_PI_4
108 #    undef M_1_PI
109 #    undef M_2_PI
110 #    undef M_2_SQRTPI
111 #    undef M_SQRT2
112 #    undef M_SQRT1_2
113 #    define FLOAT_C(c) CAT2(c,L)
114 #  else
115 #    define FLOAT_C(c) (c)
116 #  endif
117
118 #  ifndef M_E
119 #    define M_E         FLOAT_C(2.71828182845904523536028747135266250)
120 #  endif
121 #  ifndef M_LOG2E
122 #    define M_LOG2E     FLOAT_C(1.44269504088896340735992468100189214)
123 #  endif
124 #  ifndef M_LOG10E
125 #    define M_LOG10E    FLOAT_C(0.434294481903251827651128918916605082)
126 #  endif
127 #  ifndef M_LN2
128 #    define M_LN2       FLOAT_C(0.693147180559945309417232121458176568)
129 #  endif
130 #  ifndef M_LN10
131 #    define M_LN10      FLOAT_C(2.30258509299404568401799145468436421)
132 #  endif
133 #  ifndef M_PI
134 #    define M_PI        FLOAT_C(3.14159265358979323846264338327950288)
135 #  endif
136 #  ifndef M_PI_2
137 #    define M_PI_2      FLOAT_C(1.57079632679489661923132169163975144)
138 #  endif
139 #  ifndef M_PI_4
140 #    define M_PI_4      FLOAT_C(0.785398163397448309615660845819875721)
141 #  endif
142 #  ifndef M_1_PI
143 #    define M_1_PI      FLOAT_C(0.318309886183790671537767526745028724)
144 #  endif
145 #  ifndef M_2_PI
146 #    define M_2_PI      FLOAT_C(0.636619772367581343075535053490057448)
147 #  endif
148 #  ifndef M_2_SQRTPI
149 #    define M_2_SQRTPI  FLOAT_C(1.12837916709551257389615890312154517)
150 #  endif
151 #  ifndef M_SQRT2
152 #    define M_SQRT2     FLOAT_C(1.41421356237309504880168872420969808)
153 #  endif
154 #  ifndef M_SQRT1_2
155 #    define M_SQRT1_2   FLOAT_C(0.707106781186547524400844362104849039)
156 #  endif
157
158 #endif
159
160 #if !defined(INFINITY) && defined(NV_INF)
161 #  define INFINITY NV_INF
162 #endif
163
164 #if !defined(NAN) && defined(NV_NAN)
165 #  define NAN NV_NAN
166 #endif
167
168 #if !defined(Inf) && defined(NV_INF)
169 #  define Inf NV_INF
170 #endif
171
172 #if !defined(NaN) && defined(NV_NAN)
173 #  define NaN NV_NAN
174 #endif
175
176 /* We will have an emulation. */
177 #ifndef FP_INFINITE
178 #  define FP_INFINITE   0
179 #  define FP_NAN        1
180 #  define FP_NORMAL     2
181 #  define FP_SUBNORMAL  3
182 #  define FP_ZERO       4
183 #endif
184
185 /* We will have an emulation. */
186 #ifndef FE_TONEAREST
187 #  define FE_TOWARDZERO 0
188 #  define FE_TONEAREST  1
189 #  define FE_UPWARD     2
190 #  define FE_DOWNWARD   3
191 #endif
192
193 /* C89 math.h:
194
195    acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp
196    log log10 modf pow sin sinh sqrt tan tanh
197
198  * Implemented in core:
199
200    atan2 cos exp log pow sin sqrt
201
202  * C99 math.h added:
203
204    acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax
205    fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf
206    isless islessequal islessgreater isnan isnormal isunordered lgamma
207    log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder
208    remquo rint round scalbn signbit tgamma trunc
209
210    See:
211    http://pubs.opengroup.org/onlinepubs/009695399/basedefs/math.h.html
212
213  * Berkeley/SVID extensions:
214
215    j0 j1 jn y0 y1 yn
216
217  * Configure already (5.21.5) scans for:
218
219    copysign*l* fpclassify isfinite isinf isnan isnan*l* ilogb*l* signbit scalbn*l*
220
221  * For floating-point round mode (which matters for e.g. lrint and rint)
222
223    fegetround fesetround
224
225 */
226
227 /* XXX Constant FP_FAST_FMA (if true, FMA is faster) */
228
229 /* XXX Add ldiv(), lldiv()?  It's C99, but from stdlib.h, not math.h  */
230
231 /* XXX Beware old gamma() -- one cannot know whether that is the
232  * gamma or the log of gamma, that's why the new tgamma and lgamma.
233  * Though also remember lgamma_r. */
234
235 /* Certain AIX releases have the C99 math, but not in long double.
236  * The <math.h> has them, e.g. __expl128, but no library has them!
237  *
238  * Also see the comments in hints/aix.sh about long doubles. */
239
240 #if defined(USE_QUADMATH) && defined(I_QUADMATH)
241 #  define c99_acosh     acoshq
242 #  define c99_asinh     asinhq
243 #  define c99_atanh     atanhq
244 #  define c99_cbrt      cbrtq
245 #  define c99_copysign  copysignq
246 #  define c99_erf       erfq
247 #  define c99_erfc      erfcq
248 /* no exp2q */
249 #  define c99_expm1     expm1q
250 #  define c99_fdim      fdimq
251 #  define c99_fma       fmaq
252 #  define c99_fmax      fmaxq
253 #  define c99_fmin      fminq
254 #  define c99_hypot     hypotq
255 #  define c99_ilogb     ilogbq
256 #  define c99_lgamma    lgammaq
257 #  define c99_log1p     log1pq
258 #  define c99_log2      log2q
259 /* no logbq */
260 #  if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
261 #    define c99_lrint   llrintq
262 #    define c99_lround  llroundq
263 #  else
264 #    define c99_lrint   lrintq
265 #    define c99_lround  lroundq
266 #  endif
267 #  define c99_nan       nanq
268 #  define c99_nearbyint nearbyintq
269 #  define c99_nextafter nextafterq
270 /* no nexttowardq */
271 #  define c99_remainder remainderq
272 #  define c99_remquo    remquoq
273 #  define c99_rint      rintq
274 #  define c99_round     roundq
275 #  define c99_scalbn    scalbnq
276 #  define c99_signbit   signbitq
277 #  define c99_tgamma    tgammaq
278 #  define c99_trunc     truncq
279 #  define bessel_j0 j0q
280 #  define bessel_j1 j1q
281 #  define bessel_jn jnq
282 #  define bessel_y0 y0q
283 #  define bessel_y1 y1q
284 #  define bessel_yn ynq
285 #elif defined(USE_LONG_DOUBLE) && \
286   (defined(HAS_FREXPL) || defined(HAS_ILOGBL)) && defined(HAS_SQRTL)
287 /* Use some of the Configure scans for long double math functions
288  * as the canary for all the C99 *l variants being defined. */
289 #  define c99_acosh     acoshl
290 #  define c99_asinh     asinhl
291 #  define c99_atanh     atanhl
292 #  define c99_cbrt      cbrtl
293 #  define c99_copysign  copysignl
294 #  define c99_erf       erfl
295 #  define c99_erfc      erfcl
296 #  define c99_exp2      exp2l
297 #  define c99_expm1     expm1l
298 #  define c99_fdim      fdiml
299 #  define c99_fma       fmal
300 #  define c99_fmax      fmaxl
301 #  define c99_fmin      fminl
302 #  define c99_hypot     hypotl
303 #  define c99_ilogb     ilogbl
304 #  define c99_lgamma    lgammal
305 #  define c99_log1p     log1pl
306 #  define c99_log2      log2l
307 #  define c99_logb      logbl
308 #  if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINTL)
309 #    define c99_lrint   llrintl
310 #  elif defined(HAS_LRINTL)
311 #    define c99_lrint   lrintl
312 #  endif
313 #  if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUNDL)
314 #    define c99_lround  llroundl
315 #  elif defined(HAS_LROUNDL)
316 #    define c99_lround  lroundl
317 #  endif
318 #  define c99_nan       nanl
319 #  define c99_nearbyint nearbyintl
320 #  define c99_nextafter nextafterl
321 #  define c99_nexttoward        nexttowardl
322 #  define c99_remainder remainderl
323 #  define c99_remquo    remquol
324 #  define c99_rint      rintl
325 #  define c99_round     roundl
326 #  define c99_scalbn    scalbnl
327 #  ifdef HAS_SIGNBIT /* possibly bad assumption */
328 #    define c99_signbit signbitl
329 #  endif
330 #  define c99_tgamma    tgammal
331 #  define c99_trunc     truncl
332 #else
333 #  define c99_acosh     acosh
334 #  define c99_asinh     asinh
335 #  define c99_atanh     atanh
336 #  define c99_cbrt      cbrt
337 #  define c99_copysign  copysign
338 #  define c99_erf       erf
339 #  define c99_erfc      erfc
340 #  define c99_exp2      exp2
341 #  define c99_expm1     expm1
342 #  define c99_fdim      fdim
343 #  define c99_fma       fma
344 #  define c99_fmax      fmax
345 #  define c99_fmin      fmin
346 #  define c99_hypot     hypot
347 #  define c99_ilogb     ilogb
348 #  define c99_lgamma    lgamma
349 #  define c99_log1p     log1p
350 #  define c99_log2      log2
351 #  define c99_logb      logb
352 #  if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINT)
353 #    define c99_lrint   llrint
354 #  else
355 #    define c99_lrint   lrint
356 #  endif
357 #  if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUND)
358 #    define c99_lround  llround
359 #  else
360 #    define c99_lround  lround
361 #  endif
362 #  define c99_nan       nan
363 #  define c99_nearbyint nearbyint
364 #  define c99_nextafter nextafter
365 #  define c99_nexttoward        nexttoward
366 #  define c99_remainder remainder
367 #  define c99_remquo    remquo
368 #  define c99_rint      rint
369 #  define c99_round     round
370 #  define c99_scalbn    scalbn
371 /* We already define Perl_signbit in perl.h. */
372 #  ifdef HAS_SIGNBIT
373 #    define c99_signbit signbit
374 #  endif
375 #  define c99_tgamma    tgamma
376 #  define c99_trunc     trunc
377 #endif
378
379 /* AIX xlc (__IBMC__) really doesn't have the following long double
380  * math interfaces (no __acoshl128 aka acoshl, etc.), see
381  * hints/aix.sh.  These are in the -lc128 but fail to be found
382  * during dynamic linking/loading.
383  *
384  * XXX1 Better Configure scans
385  * XXX2 Is this xlc version dependent? */
386 #if defined(USE_LONG_DOUBLE) && defined(__IBMC__)
387 #  undef c99_acosh
388 #  undef c99_asinh
389 #  undef c99_atanh
390 #  undef c99_cbrt
391 #  undef c99_copysign
392 #  undef c99_exp2
393 #  undef c99_expm1
394 #  undef c99_fdim
395 #  undef c99_fma
396 #  undef c99_fmax
397 #  undef c99_fmin
398 #  undef c99_hypot
399 #  undef c99_ilogb
400 #  undef c99_lrint
401 #  undef c99_lround
402 #  undef c99_log1p
403 #  undef c99_log2
404 #  undef c99_logb
405 #  undef c99_nan
406 #  undef c99_nearbyint
407 #  undef c99_nextafter
408 #  undef c99_nexttoward
409 #  undef c99_remainder
410 #  undef c99_remquo
411 #  undef c99_rint
412 #  undef c99_round
413 #  undef c99_scalbn
414 #  undef c99_tgamma
415 #  undef c99_trunc
416 #endif
417
418 #ifndef isunordered
419 #  ifdef Perl_isnan
420 #    define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y))
421 #  elif defined(HAS_UNORDERED)
422 #    define isunordered(x, y) unordered(x, y)
423 #  endif
424 #endif
425
426 /* XXX these isgreater/isnormal/isunordered macros definitions should
427  * be moved further in the file to be part of the emulations, so that
428  * platforms can e.g. #undef c99_isunordered and have it work like
429  * it does for the other interfaces. */
430
431 #if !defined(isgreater) && defined(isunordered)
432 #  define isgreater(x, y)         (!isunordered((x), (y)) && (x) > (y))
433 #  define isgreaterequal(x, y)    (!isunordered((x), (y)) && (x) >= (y))
434 #  define isless(x, y)            (!isunordered((x), (y)) && (x) < (y))
435 #  define islessequal(x, y)       (!isunordered((x), (y)) && (x) <= (y))
436 #  define islessgreater(x, y)     (!isunordered((x), (y)) && \
437                                      ((x) > (y) || (y) > (x)))
438 #endif
439
440 /* Check both the Configure symbol and the macro-ness (like C99 promises). */ 
441 #if defined(HAS_FPCLASSIFY) && defined(fpclassify)
442 #  define c99_fpclassify        fpclassify
443 #endif
444 /* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99
445    and also (sizeof-arg-aware) macros, but they are already well taken
446    care of by Configure et al, and defined in perl.h as
447    Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */
448 #ifdef isnormal
449 #  define c99_isnormal  isnormal
450 #endif
451 #ifdef isgreater /* canary for all the C99 is*<cmp>* macros. */
452 #  define c99_isgreater isgreater
453 #  define c99_isgreaterequal    isgreaterequal
454 #  define c99_isless            isless
455 #  define c99_islessequal       islessequal
456 #  define c99_islessgreater     islessgreater
457 #  define c99_isunordered       isunordered
458 #endif
459
460 /* The Great Wall of Undef where according to the definedness of HAS_FOO symbols
461  * the corresponding c99_foo wrappers are undefined.  This list doesn't include
462  * the isfoo() interfaces because they are either type-aware macros, or dealt
463  * separately, already in perl.h */
464
465 #ifndef HAS_ACOSH
466 #  undef c99_acosh
467 #endif
468 #ifndef HAS_ASINH
469 #  undef c99_asinh
470 #endif
471 #ifndef HAS_ATANH
472 #  undef c99_atanh
473 #endif
474 #ifndef HAS_CBRT
475 #  undef c99_cbrt
476 #endif
477 #ifndef HAS_COPYSIGN
478 #  undef c99_copysign
479 #endif
480 #ifndef HAS_ERF
481 #  undef c99_erf
482 #endif
483 #ifndef HAS_ERFC
484 #  undef c99_erfc
485 #endif
486 #ifndef HAS_EXP2
487 #  undef c99_exp2
488 #endif
489 #ifndef HAS_EXPM1
490 #  undef c99_expm1
491 #endif
492 #ifndef HAS_FDIM
493 #  undef c99_fdim
494 #endif
495 #ifndef HAS_FMA
496 #  undef c99_fma
497 #endif
498 #ifndef HAS_FMAX
499 #  undef c99_fmax
500 #endif
501 #ifndef HAS_FMIN
502 #  undef c99_fmin
503 #endif
504 #ifndef HAS_FPCLASSIFY
505 #  undef c99_fpclassify
506 #endif
507 #ifndef HAS_HYPOT
508 #  undef c99_hypot
509 #endif
510 #ifndef HAS_ILOGB
511 #  undef c99_ilogb
512 #endif
513 #ifndef HAS_LGAMMA
514 #  undef c99_lgamma
515 #endif
516 #ifndef HAS_LOG1P
517 #  undef c99_log1p
518 #endif
519 #ifndef HAS_LOG2
520 #  undef c99_log2
521 #endif
522 #ifndef HAS_LOGB
523 #  undef c99_logb
524 #endif
525 #ifndef HAS_LRINT
526 #  undef c99_lrint
527 #endif
528 #ifndef HAS_LROUND
529 #  undef c99_lround
530 #endif
531 #ifndef HAS_NAN
532 #  undef c99_nan
533 #endif
534 #ifndef HAS_NEARBYINT
535 #  undef c99_nearbyint
536 #endif
537 #ifndef HAS_NEXTAFTER
538 #  undef c99_nextafter
539 #endif
540 #ifndef HAS_NEXTTOWARD
541 #  undef c99_nexttoward
542 #endif
543 #ifndef HAS_REMAINDER
544 #  undef c99_remainder
545 #endif
546 #ifndef HAS_REMQUO
547 #  undef c99_remquo
548 #endif
549 #ifndef HAS_RINT
550 #  undef c99_rint
551 #endif
552 #ifndef HAS_ROUND
553 #  undef c99_round
554 #endif
555 #ifndef HAS_SCALBN
556 #  undef c99_scalbn
557 #endif
558 #ifndef HAS_SIGNBIT
559 #  undef c99_signbit
560 #endif
561 #ifndef HAS_TGAMMA
562 #  undef c99_tgamma
563 #endif
564 #ifndef HAS_TRUNC
565 #  undef c99_trunc
566 #endif
567
568 #ifdef WIN32
569
570 /* Some APIs exist under Win32 with "underbar" names. */
571 #  undef c99_hypot
572 #  undef c99_logb
573 #  undef c99_nextafter
574 #  define c99_hypot _hypot
575 #  define c99_logb _logb
576 #  define c99_nextafter _nextafter
577
578 #  define bessel_j0 _j0
579 #  define bessel_j1 _j1
580 #  define bessel_jn _jn
581 #  define bessel_y0 _y0
582 #  define bessel_y1 _y1
583 #  define bessel_yn _yn
584
585 #endif
586
587 /* The Bessel functions: BSD, SVID, XPG4, and POSIX.  But not C99. */
588 #if defined(HAS_J0) && !defined(bessel_j0)
589 #  if defined(USE_LONG_DOUBLE) && defined(HAS_J0L)
590 #    define bessel_j0 j0l
591 #    define bessel_j1 j1l
592 #    define bessel_jn jnl
593 #    define bessel_y0 y0l
594 #    define bessel_y1 y1l
595 #    define bessel_yn ynl
596 #  else
597 #    define bessel_j0 j0
598 #    define bessel_j1 j1
599 #    define bessel_jn jn
600 #    define bessel_y0 y0
601 #    define bessel_y1 y1
602 #    define bessel_yn yn
603 #  endif
604 #endif
605
606 /* Emulations for missing math APIs.
607  *
608  * Keep in mind that the point of many of these functions is that
609  * they, if available, are supposed to give more precise/more
610  * numerically stable results.
611  *
612  * See e.g. http://www.johndcook.com/math_h.html
613  */
614
615 #ifndef c99_acosh
616 static NV my_acosh(NV x)
617 {
618   return Perl_log(x + Perl_sqrt(x * x - 1));
619 }
620 #  define c99_acosh my_acosh
621 #endif
622
623 #ifndef c99_asinh
624 static NV my_asinh(NV x)
625 {
626   return Perl_log(x + Perl_sqrt(x * x + 1));
627 }
628 #  define c99_asinh my_asinh
629 #endif
630
631 #ifndef c99_atanh
632 static NV my_atanh(NV x)
633 {
634   return (Perl_log(1 + x) - Perl_log(1 - x)) / 2;
635 }
636 #  define c99_atanh my_atanh
637 #endif
638
639 #ifndef c99_cbrt
640 static NV my_cbrt(NV x)
641 {
642   static const NV one_third = (NV)1.0/3;
643   return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third);
644 }
645 #  define c99_cbrt my_cbrt
646 #endif
647
648 #ifndef c99_copysign
649 static NV my_copysign(NV x, NV y)
650 {
651   return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x);
652 }
653 #  define c99_copysign my_copysign
654 #endif
655
656 /* XXX cosh (though c89) */
657
658 #ifndef c99_erf
659 static NV my_erf(NV x)
660 {
661   /* http://www.johndcook.com/cpp_erf.html -- public domain */
662   NV a1 =  0.254829592;
663   NV a2 = -0.284496736;
664   NV a3 =  1.421413741;
665   NV a4 = -1.453152027;
666   NV a5 =  1.061405429;
667   NV p  =  0.3275911;
668   NV t, y;
669   int sign = x < 0 ? -1 : 1; /* Save the sign. */
670   x = PERL_ABS(x);
671
672   /* Abramowitz and Stegun formula 7.1.26 */
673   t = 1.0 / (1.0 + p * x);
674   y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * Perl_exp(-x*x);
675
676   return sign * y;
677 }
678 #  define c99_erf my_erf
679 #endif
680
681 #ifndef c99_erfc
682 static NV my_erfc(NV x) {
683   /* This is not necessarily numerically stable, but better than nothing. */
684   return 1.0 - c99_erf(x);
685 }
686 #  define c99_erfc my_erfc
687 #endif
688
689 #ifndef c99_exp2
690 static NV my_exp2(NV x)
691 {
692   return Perl_pow((NV)2.0, x);
693 }
694 #  define c99_exp2 my_exp2
695 #endif
696
697 #ifndef c99_expm1
698 static NV my_expm1(NV x)
699 {
700   if (PERL_ABS(x) < 1e-5)
701     /* http://www.johndcook.com/cpp_expm1.html -- public domain.
702      * Taylor series, the first four terms (the last term quartic). */
703     /* Probably not enough for long doubles. */
704     return x * (1.0 + x * (1/2.0 + x * (1/6.0 + x/24.0)));
705   else
706     return Perl_exp(x) - 1;
707 }
708 #  define c99_expm1 my_expm1
709 #endif
710
711 #ifndef c99_fdim
712 static NV my_fdim(NV x, NV y)
713 {
714 #ifdef NV_NAN
715   return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0);
716 #else
717   return (x > y ? x - y : 0);
718 #endif
719 }
720 #  define c99_fdim my_fdim
721 #endif
722
723 #ifndef c99_fma
724 static NV my_fma(NV x, NV y, NV z)
725 {
726   return (x * y) + z;
727 }
728 #  define c99_fma my_fma
729 #endif
730
731 #ifndef c99_fmax
732 static NV my_fmax(NV x, NV y)
733 {
734 #ifdef NV_NAN
735   if (Perl_isnan(x)) {
736     return Perl_isnan(y) ? NV_NAN : y;
737   } else if (Perl_isnan(y)) {
738     return x;
739   }
740 #endif
741   return x > y ? x : y;
742 }
743 #  define c99_fmax my_fmax
744 #endif
745
746 #ifndef c99_fmin
747 static NV my_fmin(NV x, NV y)
748 {
749 #ifdef NV_NAN
750   if (Perl_isnan(x)) {
751     return Perl_isnan(y) ? NV_NAN : y;
752   } else if (Perl_isnan(y)) {
753     return x;
754   }
755 #endif
756   return x < y ? x : y;
757 }
758 #  define c99_fmin my_fmin
759 #endif
760
761 #ifndef c99_fpclassify
762
763 static IV my_fpclassify(NV x)
764 {
765 #ifdef Perl_fp_class_inf
766   if (Perl_fp_class_inf(x))    return FP_INFINITE;
767   if (Perl_fp_class_nan(x))    return FP_NAN;
768   if (Perl_fp_class_norm(x))   return FP_NORMAL;
769   if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL;
770   if (Perl_fp_class_zero(x))   return FP_ZERO;
771 #  define c99_fpclassify my_fpclassify
772 #endif
773   return -1;
774 }
775
776 #endif
777
778 #ifndef c99_hypot
779 static NV my_hypot(NV x, NV y)
780 {
781   /* http://en.wikipedia.org/wiki/Hypot */
782   NV t;
783   x = PERL_ABS(x); /* Take absolute values. */
784   if (y == 0)
785     return x;
786 #ifdef NV_INF
787   if (Perl_isnan(y))
788     return NV_INF;
789 #endif
790   y = PERL_ABS(y);
791   if (x < y) { /* Swap so that y is less. */
792     t = x;
793     x = y;
794     y = t;
795   }
796   t = y / x;
797   return x * Perl_sqrt(1.0 + t * t);
798 }
799 #  define c99_hypot my_hypot
800 #endif
801
802 #ifndef c99_ilogb
803 static IV my_ilogb(NV x)
804 {
805   return (IV)(Perl_log(x) * M_LOG2E);
806 }
807 #  define c99_ilogb my_ilogb
808 #endif
809
810 /* tgamma and lgamma emulations based on
811  * http://www.johndcook.com/cpp_gamma.html,
812  * code placed in public domain.
813  *
814  * Note that these implementations (neither the johndcook originals
815  * nor these) do NOT set the global signgam variable.  This is not
816  * necessarily a bad thing. */
817
818 /* Note that the tgamma() and lgamma() implementations
819  * here depend on each other. */
820
821 #if !defined(HAS_TGAMMA) || !defined(c99_tgamma)
822 static NV my_tgamma(NV x);
823 #  define c99_tgamma my_tgamma
824 #  define USE_MY_TGAMMA
825 #endif
826 #if !defined(HAS_LGAMMA) || !defined(c99_lgamma)
827 static NV my_lgamma(NV x);
828 #  define c99_lgamma my_lgamma
829 #  define USE_MY_LGAMMA
830 #endif
831
832 #ifdef USE_MY_TGAMMA
833 static NV my_tgamma(NV x)
834 {
835   const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */
836 #ifdef NV_NAN
837   if (Perl_isnan(x) || x < 0.0)
838     return NV_NAN;
839 #endif
840 #ifdef NV_INF
841   if (x == 0.0 || x == NV_INF)
842 #ifdef DOUBLE_IS_IEEE_FORMAT
843     return x == -0.0 ? -NV_INF : NV_INF;
844 #else
845     return NV_INF;
846 #endif
847 #endif
848
849   /* The function domain is split into three intervals:
850    * (0, 0.001), [0.001, 12), and (12, infinity) */
851
852   /* First interval: (0, 0.001)
853    * For small values, 1/tgamma(x) has power series x + gamma x^2,
854    * so in this range, 1/tgamma(x) = x + gamma x^2 with error on the order of x^3.
855    * The relative error over this interval is less than 6e-7. */
856   if (x < 0.001)
857     return 1.0 / (x * (1.0 + gamma * x));
858
859   /* Second interval: [0.001, 12) */
860   if (x < 12.0) {
861     double y = x; /* Working copy. */
862     int n = 0;
863     /* Numerator coefficients for approximation over the interval (1,2) */
864     static const NV p[] = {
865       -1.71618513886549492533811E+0,
866       2.47656508055759199108314E+1,
867       -3.79804256470945635097577E+2,
868       6.29331155312818442661052E+2,
869       8.66966202790413211295064E+2,
870       -3.14512729688483675254357E+4,
871       -3.61444134186911729807069E+4,
872       6.64561438202405440627855E+4
873     };
874     /* Denominator coefficients for approximation over the interval (1, 2) */
875     static const NV q[] = {
876       -3.08402300119738975254353E+1,
877       3.15350626979604161529144E+2,
878       -1.01515636749021914166146E+3,
879       -3.10777167157231109440444E+3,
880       2.25381184209801510330112E+4,
881       4.75584627752788110767815E+3,
882       -1.34659959864969306392456E+5,
883       -1.15132259675553483497211E+5
884     };
885     NV num = 0.0;
886     NV den = 1.0;
887     NV z;
888     NV result;
889     int i;
890
891     if (x < 1.0)
892       y += 1.0;
893     else {
894       n = (int)Perl_floor(y) - 1;
895       y -= n;
896     }
897     z = y - 1;
898     for (i = 0; i < 8; i++) {
899       num = (num + p[i]) * z;
900       den = den * z + q[i];
901     }
902     result = num / den + 1.0;
903
904     if (x < 1.0) {
905       /* Use the identity tgamma(z) = tgamma(z+1)/z
906        * The variable "result" now holds tgamma of the original y + 1
907        * Thus we use y - 1 to get back the original y. */
908       result /= (y - 1.0);
909     }
910     else {
911       /* Use the identity tgamma(z+n) = z*(z+1)* ... *(z+n-1)*tgamma(z) */
912       for (i = 0; i < n; i++)
913         result *= y++;
914     }
915
916     return result;
917   }
918
919 #ifdef NV_INF
920   /* Third interval: [12, +Inf) */
921 #if LDBL_MANT_DIG == 113 /* IEEE quad prec */
922   if (x > 1755.548) {
923     return NV_INF;
924   }
925 #else
926   if (x > 171.624) {
927     return NV_INF;
928   }
929 #endif
930 #endif
931
932   return Perl_exp(c99_lgamma(x));
933 }
934 #endif
935
936 #ifdef USE_MY_LGAMMA
937 static NV my_lgamma(NV x)
938 {
939 #ifdef NV_NAN
940   if (Perl_isnan(x))
941     return NV_NAN;
942 #endif
943 #ifdef NV_INF
944   if (x <= 0 || x == NV_INF)
945     return NV_INF;
946 #endif
947   if (x == 1.0 || x == 2.0)
948     return 0;
949   if (x < 12.0)
950     return Perl_log(PERL_ABS(c99_tgamma(x)));
951   /* Abramowitz and Stegun 6.1.41
952    * Asymptotic series should be good to at least 11 or 12 figures
953    * For error analysis, see Whittiker and Watson
954    * A Course in Modern Analysis (1927), page 252 */
955   {
956     static const NV c[8] = {
957       1.0/12.0,
958       -1.0/360.0,
959       1.0/1260.0,
960       -1.0/1680.0,
961       1.0/1188.0,
962       -691.0/360360.0,
963       1.0/156.0,
964       -3617.0/122400.0
965     };
966     NV z = 1.0 / (x * x);
967     NV sum = c[7];
968     static const NV half_log_of_two_pi =
969       0.91893853320467274178032973640562;
970     NV series;
971     int i;
972     for (i = 6; i >= 0; i--) {
973       sum *= z;
974       sum += c[i];
975     }
976     series = sum / x;
977     return (x - 0.5) * Perl_log(x) - x + half_log_of_two_pi + series;
978   }
979 }
980 #endif
981
982 #ifndef c99_log1p
983 static NV my_log1p(NV x)
984 {
985   /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain.
986    * Taylor series, the first four terms (the last term quartic). */
987 #ifdef NV_NAN
988   if (x < -1.0)
989     return NV_NAN;
990 #endif
991 #ifdef NV_INF
992   if (x == -1.0)
993     return -NV_INF;
994 #endif
995   if (PERL_ABS(x) > 1e-4)
996     return Perl_log(1.0 + x);
997   else
998     /* Probably not enough for long doubles. */
999     return x * (1.0 + x * (-1/2.0 + x * (1/3.0 - x/4.0)));
1000 }
1001 #  define c99_log1p my_log1p
1002 #endif
1003
1004 #ifndef c99_log2
1005 static NV my_log2(NV x)
1006 {
1007   return Perl_log(x) * M_LOG2E;
1008 }
1009 #  define c99_log2 my_log2
1010 #endif
1011
1012 /* XXX nextafter */
1013
1014 /* XXX nexttoward */
1015
1016 static int my_fegetround()
1017 {
1018 #ifdef HAS_FEGETROUND
1019   return fegetround();
1020 #elif defined(HAS_FPGETROUND)
1021   switch (fpgetround()) {
1022   case FP_RN: return FE_TONEAREST;
1023   case FP_RZ: return FE_TOWARDZERO;
1024   case FP_RM: return FE_DOWNWARD;
1025   case FP_RP: return FE_UPWARD;
1026   default: return -1;
1027   }
1028 #elif defined(FLT_ROUNDS)
1029   switch (FLT_ROUNDS) {
1030   case 0: return FE_TOWARDZERO;
1031   case 1: return FE_TONEAREST;
1032   case 2: return FE_UPWARD;
1033   case 3: return FE_DOWNWARD;
1034   default: return -1;
1035   }
1036 #elif defined(__osf__) /* Tru64 */
1037   switch (read_rnd()) {
1038   case FP_RND_RN: return FE_TONEAREST;
1039   case FP_RND_RZ: return FE_TOWARDZERO;
1040   case FP_RND_RM: return FE_DOWNWARD;
1041   case FP_RND_RP: return FE_UPWARD;
1042   default: return -1;
1043   }
1044 #else
1045   return -1;
1046 #endif
1047 }
1048
1049 /* Toward closest integer. */
1050 #define MY_ROUND_NEAREST(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x) - 0.5)))
1051
1052 /* Toward zero. */
1053 #define MY_ROUND_TRUNC(x) ((NV)((IV)(x)))
1054
1055 /* Toward minus infinity. */
1056 #define MY_ROUND_DOWN(x) ((NV)((IV)((x) >= 0.0 ? (x) : (x) - 0.5)))
1057
1058 /* Toward plus infinity. */
1059 #define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x))))
1060
1061 #if (!defined(c99_nearbyint) || !defined(c99_lrint)) && defined(FE_TONEAREST)
1062 static NV my_rint(NV x)
1063 {
1064 #ifdef FE_TONEAREST
1065   switch (my_fegetround()) {
1066   case FE_TONEAREST:  return MY_ROUND_NEAREST(x);
1067   case FE_TOWARDZERO: return MY_ROUND_TRUNC(x);
1068   case FE_DOWNWARD:   return MY_ROUND_DOWN(x);
1069   case FE_UPWARD:     return MY_ROUND_UP(x);
1070   default: break;
1071   }
1072 #elif defined(HAS_FPGETROUND)
1073   switch (fpgetround()) {
1074   case FP_RN: return MY_ROUND_NEAREST(x);
1075   case FP_RZ: return MY_ROUND_TRUNC(x);
1076   case FP_RM: return MY_ROUND_DOWN(x);
1077   case FE_RP: return MY_ROUND_UP(x);
1078   default: break;
1079   }
1080 #endif
1081   not_here("rint");
1082 }
1083 #endif
1084
1085 /* XXX nearbyint() and rint() are not really identical -- but the difference
1086  * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point
1087  * exceptions, while rint() is defined to MAYBE raise them.  At the moment
1088  * Perl is blissfully unaware of such fine detail of floating point. */
1089 #ifndef c99_nearbyint
1090 #  ifdef FE_TONEAREST
1091 #    define c99_nearbyrint my_rint
1092 #  endif
1093 #endif
1094
1095 #ifndef c99_lrint
1096 #  ifdef FE_TONEAREST
1097 static IV my_lrint(NV x)
1098 {
1099   return (IV)my_rint(x);
1100 }
1101 #    define c99_lrint my_lrint
1102 #  endif
1103 #endif
1104
1105 #ifndef c99_lround
1106 static IV my_lround(NV x)
1107 {
1108   return (IV)MY_ROUND_NEAREST(x);
1109 }
1110 #  define c99_lround my_lround
1111 #endif
1112
1113 /* XXX remainder */
1114
1115 /* XXX remquo */
1116
1117 #ifndef c99_rint
1118 #  ifdef FE_TONEAREST
1119 #    define c99_rint my_rint
1120 #  endif
1121 #endif
1122
1123 #ifndef c99_round
1124 static NV my_round(NV x)
1125 {
1126   return MY_ROUND_NEAREST(x);
1127 }
1128 #  define c99_round my_round
1129 #endif
1130
1131 #ifndef c99_scalbn
1132 #   if defined(Perl_ldexp) && FLT_RADIX == 2
1133 static NV my_scalbn(NV x, int y)
1134 {
1135   return Perl_ldexp(x, y);
1136 }
1137 #    define c99_scalbn my_scalbn
1138 #  endif
1139 #endif
1140
1141 /* XXX sinh (though c89) */
1142
1143 /* tgamma -- see lgamma */
1144
1145 /* XXX tanh (though c89) */
1146
1147 #ifndef c99_trunc
1148 static NV my_trunc(NV x)
1149 {
1150   return MY_ROUND_TRUNC(x);
1151 }
1152 #  define c99_trunc my_trunc
1153 #endif
1154
1155 #ifdef NV_NAN
1156
1157 #undef NV_PAYLOAD_DEBUG
1158
1159 /* NOTE: the NaN payload API implementation is hand-rolled, since the
1160  * APIs are only proposed ones as of June 2015, so very few, if any,
1161  * platforms have implementations yet, so HAS_SETPAYLOAD and such are
1162  * unlikely to be helpful.
1163  *
1164  * XXX - if the core numification wants to actually generate
1165  * the nan payload in "nan(123)", and maybe "nans(456)", for
1166  * signaling payload", this needs to be moved to e.g. numeric.c
1167  * (look for grok_infnan)
1168  *
1169  * Conversely, if the core stringification wants the nan payload
1170  * and/or the nan quiet/signaling distinction, S_getpayload()
1171  * from this file needs to be moved, to e.g. sv.c (look for S_infnan_2pv),
1172  * and the (trivial) functionality of issignaling() copied
1173  * (for generating "NaNS", or maybe even "NaNQ") -- or maybe there
1174  * are too many formatting parameters for simple stringification?
1175  */
1176
1177 /* While it might make sense for the payload to be UV or IV,
1178  * to avoid conversion loss, the proposed ISO interfaces use
1179  * a floating point input, which is then truncated to integer,
1180  * and only the integer part being used.  This is workable,
1181  * except for: (1) the conversion loss (2) suboptimal for
1182  * 32-bit integer platforms.  A workaround API for (2) and
1183  * in general for bit-honesty would be an array of integers
1184  * as the payload... but the proposed C API does nothing of
1185  * the kind. */
1186 #if NVSIZE == UVSIZE
1187 #  define NV_PAYLOAD_TYPE UV
1188 #else
1189 #  define NV_PAYLOAD_TYPE NV
1190 #endif
1191
1192 #if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
1193 #  define NV_PAYLOAD_SIZEOF_ASSERT(a) \
1194     STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2)
1195 #else
1196 #  define NV_PAYLOAD_SIZEOF_ASSERT(a) \
1197     STATIC_ASSERT_STMT(sizeof(a) == NVSIZE)
1198 #endif
1199
1200 static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
1201 {
1202   dTHX;
1203   static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1204   static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1205   UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1206   int i;
1207   NV_PAYLOAD_SIZEOF_ASSERT(m);
1208   NV_PAYLOAD_SIZEOF_ASSERT(p);
1209   *nvp = NV_NAN;
1210   /* Divide the input into the array in "base unsigned integer" in
1211    * little-endian order.  Note that the integer might be smaller than
1212    * an NV (if UV is U32, for example). */
1213 #if NVSIZE == UVSIZE
1214   a[0] = payload;  /* The trivial case. */
1215 #else
1216   {
1217     NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */
1218 #ifdef NV_PAYLOAD_DEBUG
1219     Perl_warn(aTHX_ "t1 = %" NVgf " (payload %" NVgf ")\n", t1, payload);
1220 #endif
1221     if (t1 <= UV_MAX) {
1222       a[0] = (UV)t1;  /* Fast path, also avoids rounding errors (right?) */
1223     } else {
1224       /* UVSIZE < NVSIZE or payload > UV_MAX.
1225        *
1226        * This may happen for example if:
1227        * (1) UVSIZE == 32 and common 64-bit double NV
1228        *     (32-bit system not using -Duse64bitint)
1229        * (2) UVSIZE == 64 and the x86-style 80-bit long double NV
1230        *     (note that here the room for payload is actually the 64 bits)
1231        * (3) UVSIZE == 64 and the 128-bit IEEE 764 quadruple NV
1232        *     (112 bits in mantissa, 111 bits room for payload)
1233        *
1234        * NOTE: this is very sensitive to correctly functioning
1235        * fmod()/fmodl(), and correct casting of big-unsigned-integer to NV.
1236        * If these don't work right, especially the low order bits
1237        * are in danger.  For example Solaris and AIX seem to have issues
1238        * here, especially if using 32-bit UVs. */
1239       NV t2;
1240       for (i = 0, t2 = t1; i < (int)C_ARRAY_LENGTH(a); i++) {
1241         a[i] = (UV)Perl_fmod(t2, (NV)UV_MAX);
1242         t2 = Perl_floor(t2 / (NV)UV_MAX);
1243       }
1244     }
1245   }
1246 #endif
1247 #ifdef NV_PAYLOAD_DEBUG
1248   for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
1249     Perl_warn(aTHX_ "a[%d] = 0x%" UVxf "\n", i, a[i]);
1250   }
1251 #endif
1252   for (i = 0; i < (int)sizeof(p); i++) {
1253     if (m[i] && p[i] < sizeof(p)) {
1254       U8 s = (p[i] % UVSIZE) << 3;
1255       UV u = a[p[i] / UVSIZE] & ((UV)0xFF << s);
1256       U8 b = (U8)((u >> s) & m[i]);
1257       ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */
1258       ((U8 *)(nvp))[i] |= b;
1259 #ifdef NV_PAYLOAD_DEBUG
1260       Perl_warn(aTHX_
1261                 "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08"
1262                 UVxf ")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u);
1263 #endif
1264       a[p[i] / UVSIZE] &= ~u;
1265     }
1266   }
1267   if (signaling) {
1268     NV_NAN_SET_SIGNALING(nvp);
1269   }
1270 #ifdef USE_LONG_DOUBLE
1271 # if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4
1272 #  if LONG_DOUBLESIZE > 10
1273   memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */
1274 #  endif
1275 # endif
1276 #endif
1277   for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
1278     if (a[i]) {
1279       Perl_warn(aTHX_ "payload lost bits (%" UVxf ")", a[i]);
1280       break;
1281     }
1282   }
1283 #ifdef NV_PAYLOAD_DEBUG
1284   for (i = 0; i < NVSIZE; i++) {
1285     PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]);
1286   }
1287   PerlIO_printf(Perl_debug_log, "\n");
1288 #endif
1289 }
1290
1291 static NV_PAYLOAD_TYPE S_getpayload(NV nv)
1292 {
1293   dTHX;
1294   static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1295   static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1296   UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1297   int i;
1298   NV payload;
1299   NV_PAYLOAD_SIZEOF_ASSERT(m);
1300   NV_PAYLOAD_SIZEOF_ASSERT(p);
1301   payload = 0;
1302   for (i = 0; i < (int)sizeof(p); i++) {
1303     if (m[i] && p[i] < NVSIZE) {
1304       U8 s = (p[i] % UVSIZE) << 3;
1305       a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s;
1306     }
1307   }
1308   for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) {
1309 #ifdef NV_PAYLOAD_DEBUG
1310     Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]);
1311 #endif
1312     payload *= UV_MAX;
1313     payload += a[i];
1314   }
1315 #ifdef NV_PAYLOAD_DEBUG
1316   for (i = 0; i < NVSIZE; i++) {
1317     PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]);
1318   }
1319   PerlIO_printf(Perl_debug_log, "\n");
1320 #endif
1321   return payload;
1322 }
1323
1324 #endif  /* #ifdef NV_NAN */
1325
1326 /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
1327    metaconfig for future extension writers.  We don't use them in POSIX.
1328    (This is really sneaky :-)  --AD
1329 */
1330 #if defined(I_TERMIOS)
1331 #include <termios.h>
1332 #endif
1333 #include <stdlib.h>
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 (strNE(perl_tz_env, crt_tz_env)) {
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 #  if defined(USE_ITHREADS)                                             \
2128    && defined(HAS_POSIX_2008_LOCALE)                                    \
2129    && defined(HAS_LOCALECONV_L) /* Prefer this thread-safe version */
2130         bool do_free = FALSE;
2131         locale_t cur = uselocale((locale_t) 0);
2132 #  endif
2133         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2134
2135         /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
2136          * LC_MONETARY is already in the correct locale */
2137 #  ifdef USE_LOCALE_MONETARY
2138
2139         const bool is_monetary_utf8 = _is_cur_LC_category_utf8(LC_MONETARY);
2140 #  endif
2141 #  ifdef USE_LOCALE_NUMERIC
2142
2143         bool is_numeric_utf8;
2144
2145         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2146
2147         is_numeric_utf8 = _is_cur_LC_category_utf8(LC_NUMERIC);
2148 #  endif
2149
2150         RETVAL = newHV();
2151         sv_2mortal((SV*)RETVAL);
2152 #  if defined(USE_ITHREADS)                         \
2153    && defined(HAS_POSIX_2008_LOCALE)                \
2154    && defined(HAS_LOCALECONV_L)
2155
2156         if (cur == LC_GLOBAL_LOCALE) {
2157             cur = duplocale(LC_GLOBAL_LOCALE);
2158             do_free = TRUE;
2159         }
2160
2161         lcbuf = localeconv_l(cur);
2162 #  else
2163         LOCALE_LOCK;    /* Prevent interference with other threads using
2164                            localeconv() */
2165
2166         lcbuf = localeconv();
2167 #  endif
2168         if (lcbuf) {
2169             const struct lconv_offset *strings = lconv_strings;
2170             const struct lconv_offset *integers = lconv_integers;
2171             const char *ptr = (const char *) lcbuf;
2172
2173             while (strings->name) {
2174                 /* This string may be controlled by either LC_NUMERIC, or
2175                  * LC_MONETARY */
2176                 const bool is_utf8_locale =
2177 #  if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
2178                                         (isLC_NUMERIC_STRING(strings->name))
2179                                         ? is_numeric_utf8
2180                                         : is_monetary_utf8;
2181 #  elif defined(USE_LOCALE_NUMERIC)
2182                                         is_numeric_utf8;
2183 #  elif defined(USE_LOCALE_MONETARY)
2184                                         is_monetary_utf8;
2185 #  else
2186                                         FALSE;
2187 #  endif
2188
2189                 const char *value = *((const char **)(ptr + strings->offset));
2190
2191                 if (value && *value) {
2192                     const STRLEN value_len = strlen(value);
2193
2194                     /* We mark it as UTF-8 if a utf8 locale and is valid and
2195                      * variant under UTF-8 */
2196                     const bool is_utf8 = is_utf8_locale
2197                                      &&  is_utf8_non_invariant_string(
2198                                                                 (U8*) value,
2199                                                                 value_len);
2200                     (void) hv_store(RETVAL,
2201                                     strings->name,
2202                                     strlen(strings->name),
2203                                     newSVpvn_utf8(value, value_len, is_utf8),
2204                                     0);
2205             }
2206                 strings++;
2207             }
2208
2209             while (integers->name) {
2210                 const char value = *((const char *)(ptr + integers->offset));
2211
2212                 if (value != CHAR_MAX)
2213                     (void) hv_store(RETVAL, integers->name,
2214                                     strlen(integers->name), newSViv(value), 0);
2215                 integers++;
2216             }
2217         }
2218 #  if defined(USE_ITHREADS)                         \
2219    && defined(HAS_POSIX_2008_LOCALE)                \
2220    && defined(HAS_LOCALECONV_L)
2221         if (do_free) {
2222             freelocale(cur);
2223         }
2224 #  else
2225         LOCALE_UNLOCK;
2226 #  endif
2227         RESTORE_LC_NUMERIC();
2228 #endif  /* HAS_LOCALECONV */
2229     OUTPUT:
2230         RETVAL
2231
2232 char *
2233 setlocale(category, locale = 0)
2234         int             category
2235         const char *    locale
2236     PREINIT:
2237         char *          retval;
2238     CODE:
2239         retval = Perl_setlocale(category, locale);
2240         if (! retval) { /* Should never happen that a query would return an
2241                          * error, but be sure */
2242             XSRETURN_UNDEF;
2243         }
2244
2245         /* Make sure the returned copy gets cleaned up */
2246         SAVEFREEPV(retval);
2247
2248         RETVAL = retval;
2249     OUTPUT:
2250         RETVAL
2251
2252 NV
2253 acos(x)
2254         NV              x
2255     ALIAS:
2256         acosh = 1
2257         asin = 2
2258         asinh = 3
2259         atan = 4
2260         atanh = 5
2261         cbrt = 6
2262         ceil = 7
2263         cosh = 8
2264         erf = 9
2265         erfc = 10
2266         exp2 = 11
2267         expm1 = 12
2268         floor = 13
2269         j0 = 14
2270         j1 = 15
2271         lgamma = 16
2272         log10 = 17
2273         log1p = 18
2274         log2 = 19
2275         logb = 20
2276         nearbyint = 21
2277         rint = 22
2278         round = 23
2279         sinh = 24
2280         tan = 25
2281         tanh = 26
2282         tgamma = 27
2283         trunc = 28
2284         y0 = 29
2285         y1 = 30
2286     CODE:
2287         PERL_UNUSED_VAR(x);
2288 #ifdef NV_NAN
2289         RETVAL = NV_NAN;
2290 #else
2291         RETVAL = 0;
2292 #endif
2293         switch (ix) {
2294         case 0:
2295             RETVAL = Perl_acos(x); /* C89 math */
2296             break;
2297         case 1:
2298 #ifdef c99_acosh
2299             RETVAL = c99_acosh(x);
2300 #else
2301             not_here("acosh");
2302 #endif
2303             break;
2304         case 2:
2305             RETVAL = Perl_asin(x); /* C89 math */
2306             break;
2307         case 3:
2308 #ifdef c99_asinh
2309             RETVAL = c99_asinh(x);
2310 #else
2311             not_here("asinh");
2312 #endif
2313             break;
2314         case 4:
2315             RETVAL = Perl_atan(x); /* C89 math */
2316             break;
2317         case 5:
2318 #ifdef c99_atanh
2319             RETVAL = c99_atanh(x);
2320 #else
2321             not_here("atanh");
2322 #endif
2323             break;
2324         case 6:
2325 #ifdef c99_cbrt
2326             RETVAL = c99_cbrt(x);
2327 #else
2328             not_here("cbrt");
2329 #endif
2330             break;
2331         case 7:
2332             RETVAL = Perl_ceil(x); /* C89 math */
2333             break;
2334         case 8:
2335             RETVAL = Perl_cosh(x); /* C89 math */
2336             break;
2337         case 9:
2338 #ifdef c99_erf
2339             RETVAL = c99_erf(x);
2340 #else
2341             not_here("erf");
2342 #endif
2343             break;
2344         case 10:
2345 #ifdef c99_erfc
2346             RETVAL = c99_erfc(x);
2347 #else
2348             not_here("erfc");
2349 #endif
2350             break;
2351         case 11:
2352 #ifdef c99_exp2
2353             RETVAL = c99_exp2(x);
2354 #else
2355             not_here("exp2");
2356 #endif
2357             break;
2358         case 12:
2359 #ifdef c99_expm1
2360             RETVAL = c99_expm1(x);
2361 #else
2362             not_here("expm1");
2363 #endif
2364             break;
2365         case 13:
2366             RETVAL = Perl_floor(x); /* C89 math */
2367             break;
2368         case 14:
2369 #ifdef bessel_j0
2370             RETVAL = bessel_j0(x);
2371 #else
2372             not_here("j0");
2373 #endif
2374             break;
2375         case 15:
2376 #ifdef bessel_j1
2377             RETVAL = bessel_j1(x);
2378 #else
2379             not_here("j1");
2380 #endif
2381             break;
2382         case 16:
2383         /* XXX Note: the lgamma modifies a global variable (signgam),
2384          * which is evil.  Some platforms have lgamma_r, which has
2385          * extra output parameter instead of the global variable. */
2386 #ifdef c99_lgamma
2387             RETVAL = c99_lgamma(x);
2388 #else
2389             not_here("lgamma");
2390 #endif
2391             break;
2392         case 17:
2393             RETVAL = log10(x); /* C89 math */
2394             break;
2395         case 18:
2396 #ifdef c99_log1p
2397             RETVAL = c99_log1p(x);
2398 #else
2399             not_here("log1p");
2400 #endif
2401             break;
2402         case 19:
2403 #ifdef c99_log2
2404             RETVAL = c99_log2(x);
2405 #else
2406             not_here("log2");
2407 #endif
2408             break;
2409         case 20:
2410 #ifdef c99_logb
2411             RETVAL = c99_logb(x);
2412 #elif defined(c99_log2) && FLT_RADIX == 2
2413             RETVAL = Perl_floor(c99_log2(PERL_ABS(x)));
2414 #else
2415             not_here("logb");
2416 #endif
2417             break;
2418         case 21:
2419 #ifdef c99_nearbyint
2420             RETVAL = c99_nearbyint(x);
2421 #else
2422             not_here("nearbyint");
2423 #endif
2424             break;
2425         case 22:
2426 #ifdef c99_rint
2427             RETVAL = c99_rint(x);
2428 #else
2429             not_here("rint");
2430 #endif
2431             break;
2432         case 23:
2433 #ifdef c99_round
2434             RETVAL = c99_round(x);
2435 #else
2436             not_here("round");
2437 #endif
2438             break;
2439         case 24:
2440             RETVAL = Perl_sinh(x); /* C89 math */
2441             break;
2442         case 25:
2443             RETVAL = Perl_tan(x); /* C89 math */
2444             break;
2445         case 26:
2446             RETVAL = Perl_tanh(x); /* C89 math */
2447             break;
2448         case 27:
2449 #ifdef c99_tgamma
2450             RETVAL = c99_tgamma(x);
2451 #else
2452             not_here("tgamma");
2453 #endif
2454             break;
2455         case 28:
2456 #ifdef c99_trunc
2457             RETVAL = c99_trunc(x);
2458 #else
2459             not_here("trunc");
2460 #endif
2461             break;
2462         case 29:
2463 #ifdef bessel_y0
2464             RETVAL = bessel_y0(x);
2465 #else
2466             not_here("y0");
2467 #endif
2468             break;
2469         case 30:
2470         default:
2471 #ifdef bessel_y1
2472             RETVAL = bessel_y1(x);
2473 #else
2474             not_here("y1");
2475 #endif
2476         }
2477     OUTPUT:
2478         RETVAL
2479
2480 IV
2481 fegetround()
2482     CODE:
2483 #ifdef HAS_FEGETROUND
2484         RETVAL = my_fegetround();
2485 #else
2486         RETVAL = -1;
2487         not_here("fegetround");
2488 #endif
2489     OUTPUT:
2490         RETVAL
2491
2492 IV
2493 fesetround(x)
2494         IV      x
2495     CODE:
2496 #ifdef HAS_FEGETROUND /* canary for fesetround */
2497         RETVAL = fesetround(x);
2498 #elif defined(HAS_FPGETROUND) /* canary for fpsetround */
2499         switch (x) {
2500         case FE_TONEAREST:  RETVAL = fpsetround(FP_RN); break;
2501         case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
2502         case FE_DOWNWARD:   RETVAL = fpsetround(FP_RM); break;
2503         case FE_UPWARD:     RETVAL = fpsetround(FP_RP); break;
2504         default: RETVAL = -1; break;
2505         }
2506 #elif defined(__osf__) /* Tru64 */
2507         switch (x) {
2508         case FE_TONEAREST:  RETVAL = write_rnd(FP_RND_RN); break;
2509         case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break;
2510         case FE_DOWNWARD:   RETVAL = write_rnd(FP_RND_RM); break;
2511         case FE_UPWARD:     RETVAL = write_rnd(FP_RND_RP); break;
2512         default: RETVAL = -1; break;
2513         }
2514 #else
2515         PERL_UNUSED_VAR(x);
2516         RETVAL = -1;
2517         not_here("fesetround");
2518 #endif
2519     OUTPUT:
2520         RETVAL
2521
2522 IV
2523 fpclassify(x)
2524         NV              x
2525     ALIAS:
2526         ilogb = 1
2527         isfinite = 2
2528         isinf = 3
2529         isnan = 4
2530         isnormal = 5
2531         lrint = 6
2532         lround = 7
2533         signbit = 8
2534     CODE:
2535         PERL_UNUSED_VAR(x);
2536         RETVAL = -1;
2537         switch (ix) {
2538         case 0:
2539 #ifdef c99_fpclassify
2540             RETVAL = c99_fpclassify(x);
2541 #else
2542             not_here("fpclassify");
2543 #endif
2544             break;
2545         case 1:
2546 #ifdef c99_ilogb
2547             RETVAL = c99_ilogb(x);
2548 #else
2549             not_here("ilogb");
2550 #endif
2551             break;
2552         case 2:
2553             RETVAL = Perl_isfinite(x);
2554             break;
2555         case 3:
2556             RETVAL = Perl_isinf(x);
2557             break;
2558         case 4:
2559             RETVAL = Perl_isnan(x);
2560             break;
2561         case 5:
2562 #ifdef c99_isnormal
2563             RETVAL = c99_isnormal(x);
2564 #else
2565             not_here("isnormal");
2566 #endif
2567             break;
2568         case 6:
2569 #ifdef c99_lrint
2570             RETVAL = c99_lrint(x);
2571 #else
2572             not_here("lrint");
2573 #endif
2574             break;
2575         case 7:
2576 #ifdef c99_lround
2577             RETVAL = c99_lround(x);
2578 #else
2579             not_here("lround");
2580 #endif
2581             break;
2582         case 8:
2583         default:
2584 #ifdef Perl_signbit
2585             RETVAL = Perl_signbit(x);
2586 #else
2587             RETVAL = (x < 0);
2588 #ifdef DOUBLE_IS_IEEE_FORMAT
2589             if (x == -0.0) {
2590               RETVAL = TRUE;
2591             }
2592 #endif
2593 #endif
2594             break;
2595         }
2596     OUTPUT:
2597         RETVAL
2598
2599 NV
2600 getpayload(nv)
2601         NV nv
2602     CODE:
2603 #ifdef DOUBLE_HAS_NAN
2604         RETVAL = S_getpayload(nv);
2605 #else
2606         PERL_UNUSED_VAR(nv);
2607         RETVAL = 0.0;
2608         not_here("getpayload");
2609 #endif
2610     OUTPUT:
2611         RETVAL
2612
2613 void
2614 setpayload(nv, payload)
2615         NV nv
2616         NV payload
2617     CODE:
2618 #ifdef DOUBLE_HAS_NAN
2619         S_setpayload(&nv, payload, FALSE);
2620 #else
2621         PERL_UNUSED_VAR(nv);
2622         PERL_UNUSED_VAR(payload);
2623         not_here("setpayload");
2624 #endif
2625     OUTPUT:
2626         nv
2627
2628 void
2629 setpayloadsig(nv, payload)
2630         NV nv
2631         NV payload
2632     CODE:
2633 #ifdef DOUBLE_HAS_NAN
2634         nv = NV_NAN;
2635         S_setpayload(&nv, payload, TRUE);
2636 #else
2637         PERL_UNUSED_VAR(nv);
2638         PERL_UNUSED_VAR(payload);
2639         not_here("setpayloadsig");
2640 #endif
2641     OUTPUT:
2642         nv
2643
2644 int
2645 issignaling(nv)
2646         NV nv
2647     CODE:
2648 #ifdef DOUBLE_HAS_NAN
2649         RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv);
2650 #else
2651         PERL_UNUSED_VAR(nv);
2652         RETVAL = 0.0;
2653         not_here("issignaling");
2654 #endif
2655     OUTPUT:
2656         RETVAL
2657
2658 NV
2659 copysign(x,y)
2660         NV              x
2661         NV              y
2662     ALIAS:
2663         fdim = 1
2664         fmax = 2
2665         fmin = 3
2666         fmod = 4
2667         hypot = 5
2668         isgreater = 6
2669         isgreaterequal = 7
2670         isless = 8
2671         islessequal = 9
2672         islessgreater = 10
2673         isunordered = 11
2674         nextafter = 12
2675         nexttoward = 13
2676         remainder = 14
2677     CODE:
2678         PERL_UNUSED_VAR(x);
2679         PERL_UNUSED_VAR(y);
2680 #ifdef NV_NAN
2681         RETVAL = NV_NAN;
2682 #else
2683         RETVAL = 0;
2684 #endif
2685         switch (ix) {
2686         case 0:
2687 #ifdef c99_copysign
2688             RETVAL = c99_copysign(x, y);
2689 #else
2690             not_here("copysign");
2691 #endif
2692             break;
2693         case 1:
2694 #ifdef c99_fdim
2695             RETVAL = c99_fdim(x, y);
2696 #else
2697             not_here("fdim");
2698 #endif
2699             break;
2700         case 2:
2701 #ifdef c99_fmax
2702             RETVAL = c99_fmax(x, y);
2703 #else
2704             not_here("fmax");
2705 #endif
2706             break;
2707         case 3:
2708 #ifdef c99_fmin
2709             RETVAL = c99_fmin(x, y);
2710 #else
2711             not_here("fmin");
2712 #endif
2713             break;
2714         case 4:
2715             RETVAL = Perl_fmod(x, y); /* C89 math */
2716             break;
2717         case 5:
2718 #ifdef c99_hypot
2719             RETVAL = c99_hypot(x, y);
2720 #else
2721             not_here("hypot");
2722 #endif
2723             break;
2724         case 6:
2725 #ifdef c99_isgreater
2726             RETVAL = c99_isgreater(x, y);
2727 #else
2728             not_here("isgreater");
2729 #endif
2730             break;
2731         case 7:
2732 #ifdef c99_isgreaterequal
2733             RETVAL = c99_isgreaterequal(x, y);
2734 #else
2735             not_here("isgreaterequal");
2736 #endif
2737             break;
2738         case 8:
2739 #ifdef c99_isless
2740             RETVAL = c99_isless(x, y);
2741 #else
2742             not_here("isless");
2743 #endif
2744             break;
2745         case 9:
2746 #ifdef c99_islessequal
2747             RETVAL = c99_islessequal(x, y);
2748 #else
2749             not_here("islessequal");
2750 #endif
2751             break;
2752         case 10:
2753 #ifdef c99_islessgreater
2754             RETVAL = c99_islessgreater(x, y);
2755 #else
2756             not_here("islessgreater");
2757 #endif
2758             break;
2759         case 11:
2760 #ifdef c99_isunordered
2761             RETVAL = c99_isunordered(x, y);
2762 #else
2763             not_here("isunordered");
2764 #endif
2765             break;
2766         case 12:
2767 #ifdef c99_nextafter
2768             RETVAL = c99_nextafter(x, y);
2769 #else
2770             not_here("nextafter");
2771 #endif
2772             break;
2773         case 13:
2774 #ifdef c99_nexttoward
2775             RETVAL = c99_nexttoward(x, y);
2776 #else
2777             not_here("nexttoward");
2778 #endif
2779             break;
2780         case 14:
2781         default:
2782 #ifdef c99_remainder
2783           RETVAL = c99_remainder(x, y);
2784 #else
2785           not_here("remainder");
2786 #endif
2787             break;
2788         }
2789         OUTPUT:
2790             RETVAL
2791
2792 void
2793 frexp(x)
2794         NV              x
2795     PPCODE:
2796         int expvar;
2797         /* (We already know stack is long enough.) */
2798         PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2799         PUSHs(sv_2mortal(newSViv(expvar)));
2800
2801 NV
2802 ldexp(x,exp)
2803         NV              x
2804         int             exp
2805
2806 void
2807 modf(x)
2808         NV              x
2809     PPCODE:
2810         NV intvar;
2811         /* (We already know stack is long enough.) */
2812         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2813         PUSHs(sv_2mortal(newSVnv(intvar)));
2814
2815 void
2816 remquo(x,y)
2817         NV              x
2818         NV              y
2819     PPCODE:
2820 #ifdef c99_remquo
2821         int intvar;
2822         PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2823         PUSHs(sv_2mortal(newSVnv(intvar)));
2824 #else
2825         PERL_UNUSED_VAR(x);
2826         PERL_UNUSED_VAR(y);
2827         not_here("remquo");
2828 #endif
2829
2830 NV
2831 scalbn(x,y)
2832         NV              x
2833         IV              y
2834     CODE:
2835 #ifdef c99_scalbn
2836         RETVAL = c99_scalbn(x, y);
2837 #else
2838         PERL_UNUSED_VAR(x);
2839         PERL_UNUSED_VAR(y);
2840         RETVAL = NV_NAN;
2841         not_here("scalbn");
2842 #endif
2843     OUTPUT:
2844         RETVAL
2845
2846 NV
2847 fma(x,y,z)
2848         NV              x
2849         NV              y
2850         NV              z
2851     CODE:
2852 #ifdef c99_fma
2853         RETVAL = c99_fma(x, y, z);
2854 #else
2855         PERL_UNUSED_VAR(x);
2856         PERL_UNUSED_VAR(y);
2857         PERL_UNUSED_VAR(z);
2858         not_here("fma");
2859 #endif
2860     OUTPUT:
2861         RETVAL
2862
2863 NV
2864 nan(payload = 0)
2865         NV payload
2866     CODE:
2867 #ifdef NV_NAN
2868         /* If no payload given, just return the default NaN.
2869          * This makes a difference in platforms where the default
2870          * NaN is not all zeros. */
2871         if (items == 0) {
2872           RETVAL = NV_NAN;
2873         } else {
2874           S_setpayload(&RETVAL, payload, FALSE);
2875         }
2876 #elif defined(c99_nan)
2877         {
2878           STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload);
2879           if ((IV)elen == -1) {
2880 #ifdef NV_NAN
2881             RETVAL = NV_NAN;
2882 #else            
2883             RETVAL = 0.0;
2884             not_here("nan");
2885 #endif
2886           } else {
2887             RETVAL = c99_nan(PL_efloatbuf);
2888           }
2889         }
2890 #else
2891         not_here("nan");
2892 #endif
2893     OUTPUT:
2894         RETVAL
2895
2896 NV
2897 jn(x,y)
2898         IV              x
2899         NV              y
2900     ALIAS:
2901         yn = 1
2902     CODE:
2903 #ifdef NV_NAN
2904         RETVAL = NV_NAN;
2905 #else
2906         RETVAL = 0;
2907 #endif
2908         switch (ix) {
2909         case 0:
2910 #ifdef bessel_jn
2911           RETVAL = bessel_jn(x, y);
2912 #else
2913           PERL_UNUSED_VAR(x);
2914           PERL_UNUSED_VAR(y);
2915           not_here("jn");
2916 #endif
2917             break;
2918         case 1:
2919         default:
2920 #ifdef bessel_yn
2921           RETVAL = bessel_yn(x, y);
2922 #else
2923           PERL_UNUSED_VAR(x);
2924           PERL_UNUSED_VAR(y);
2925           not_here("yn");
2926 #endif
2927             break;
2928         }
2929     OUTPUT:
2930         RETVAL
2931
2932 SysRet
2933 sigaction(sig, optaction, oldaction = 0)
2934         int                     sig
2935         SV *                    optaction
2936         POSIX::SigAction        oldaction
2937     CODE:
2938 #if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__))
2939         RETVAL = not_here("sigaction");
2940 #else
2941 # This code is really grody because we are trying to make the signal
2942 # interface look beautiful, which is hard.
2943
2944         {
2945             dVAR;
2946             POSIX__SigAction action;
2947             GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
2948             struct sigaction act;
2949             struct sigaction oact;
2950             sigset_t sset;
2951             SV *osset_sv;
2952             sigset_t osset;
2953             POSIX__SigSet sigset;
2954             SV** svp;
2955             SV** sigsvp;
2956
2957             if (sig < 0) {
2958                 croak("Negative signals are not allowed");
2959             }
2960
2961             if (sig == 0 && SvPOK(ST(0))) {
2962                 const char *s = SvPVX_const(ST(0));
2963                 int i = whichsig(s);
2964
2965                 if (i < 0 && memBEGINs(s, SvCUR(ST(0)), "SIG"))
2966                     i = whichsig(s + 3);
2967                 if (i < 0) {
2968                     if (ckWARN(WARN_SIGNAL))
2969                         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2970                                     "No such signal: SIG%s", s);
2971                     XSRETURN_UNDEF;
2972                 }
2973                 else
2974                     sig = i;
2975             }
2976 #ifdef NSIG
2977             if (sig > NSIG) { /* NSIG - 1 is still okay. */
2978                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2979                             "No such signal: %d", sig);
2980                 XSRETURN_UNDEF;
2981             }
2982 #endif
2983             sigsvp = hv_fetch(GvHVn(siggv),
2984                               PL_sig_name[sig],
2985                               strlen(PL_sig_name[sig]),
2986                               TRUE);
2987
2988             /* Check optaction and set action */
2989             if(SvTRUE(optaction)) {
2990                 if(sv_isa(optaction, "POSIX::SigAction"))
2991                         action = (HV*)SvRV(optaction);
2992                 else
2993                         croak("action is not of type POSIX::SigAction");
2994             }
2995             else {
2996                 action=0;
2997             }
2998
2999             /* sigaction() is supposed to look atomic. In particular, any
3000              * signal handler invoked during a sigaction() call should
3001              * see either the old or the new disposition, and not something
3002              * in between. We use sigprocmask() to make it so.
3003              */
3004             sigfillset(&sset);
3005             RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
3006             if(RETVAL == -1)
3007                XSRETURN_UNDEF;
3008             ENTER;
3009             /* Restore signal mask no matter how we exit this block. */
3010             osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
3011             SAVEFREESV( osset_sv );
3012             SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
3013
3014             RETVAL=-1; /* In case both oldaction and action are 0. */
3015
3016             /* Remember old disposition if desired. */
3017             if (oldaction) {
3018                 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
3019                 if(!svp)
3020                     croak("Can't supply an oldaction without a HANDLER");
3021                 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
3022                         sv_setsv(*svp, *sigsvp);
3023                 }
3024                 else {
3025                         sv_setpvs(*svp, "DEFAULT");
3026                 }
3027                 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
3028                 if(RETVAL == -1) {
3029                    LEAVE;
3030                    XSRETURN_UNDEF;
3031                 }
3032                 /* Get back the mask. */
3033                 svp = hv_fetchs(oldaction, "MASK", TRUE);
3034                 if (sv_isa(*svp, "POSIX::SigSet")) {
3035                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3036                 }
3037                 else {
3038                     sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
3039                                                           sizeof(sigset_t),
3040                                                           "POSIX::SigSet");
3041                 }
3042                 *sigset = oact.sa_mask;
3043
3044                 /* Get back the flags. */
3045                 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
3046                 sv_setiv(*svp, oact.sa_flags);
3047
3048                 /* Get back whether the old handler used safe signals. */
3049                 svp = hv_fetchs(oldaction, "SAFE", TRUE);
3050                 sv_setiv(*svp,
3051                 /* compare incompatible pointers by casting to integer */
3052                     PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
3053             }
3054
3055             if (action) {
3056                 /* Safe signals use "csighandler", which vectors through the
3057                    PL_sighandlerp pointer when it's safe to do so.
3058                    (BTW, "csighandler" is very different from "sighandler".) */
3059                 svp = hv_fetchs(action, "SAFE", FALSE);
3060                 act.sa_handler =
3061                         DPTR2FPTR(
3062                             void (*)(int),
3063                             (*svp && SvTRUE(*svp))
3064                                 ? PL_csighandlerp : PL_sighandlerp
3065                         );
3066
3067                 /* Vector new Perl handler through %SIG.
3068                    (The core signal handlers read %SIG to dispatch.) */
3069                 svp = hv_fetchs(action, "HANDLER", FALSE);
3070                 if (!svp)
3071                     croak("Can't supply an action without a HANDLER");
3072                 sv_setsv(*sigsvp, *svp);
3073
3074                 /* This call actually calls sigaction() with almost the
3075                    right settings, including appropriate interpretation
3076                    of DEFAULT and IGNORE.  However, why are we doing
3077                    this when we're about to do it again just below?  XXX */
3078                 SvSETMAGIC(*sigsvp);
3079
3080                 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
3081                 if(SvPOK(*svp)) {
3082                         const char *s=SvPVX_const(*svp);
3083                         if(strEQ(s,"IGNORE")) {
3084                                 act.sa_handler = SIG_IGN;
3085                         }
3086                         else if(strEQ(s,"DEFAULT")) {
3087                                 act.sa_handler = SIG_DFL;
3088                         }
3089                 }
3090
3091                 /* Set up any desired mask. */
3092                 svp = hv_fetchs(action, "MASK", FALSE);
3093                 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
3094                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3095                     act.sa_mask = *sigset;
3096                 }
3097                 else
3098                     sigemptyset(& act.sa_mask);
3099
3100                 /* Set up any desired flags. */
3101                 svp = hv_fetchs(action, "FLAGS", FALSE);
3102                 act.sa_flags = svp ? SvIV(*svp) : 0;
3103
3104                 /* Don't worry about cleaning up *sigsvp if this fails,
3105                  * because that means we tried to disposition a
3106                  * nonblockable signal, in which case *sigsvp is
3107                  * essentially meaningless anyway.
3108                  */
3109                 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
3110                 if(RETVAL == -1) {
3111                     LEAVE;
3112                     XSRETURN_UNDEF;
3113                 }
3114             }
3115
3116             LEAVE;
3117         }
3118 #endif
3119     OUTPUT:
3120         RETVAL
3121
3122 SysRet
3123 sigpending(sigset)
3124         POSIX::SigSet           sigset
3125     ALIAS:
3126         sigsuspend = 1
3127     CODE:
3128 #ifdef __amigaos4__
3129         RETVAL = not_here("sigpending");
3130 #else
3131         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
3132 #endif
3133     OUTPUT:
3134         RETVAL
3135     CLEANUP:
3136     PERL_ASYNC_CHECK();
3137
3138 SysRet
3139 sigprocmask(how, sigset, oldsigset = 0)
3140         int                     how
3141         POSIX::SigSet           sigset = NO_INIT
3142         POSIX::SigSet           oldsigset = NO_INIT
3143 INIT:
3144         if (! SvOK(ST(1))) {
3145             sigset = NULL;
3146         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
3147             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
3148         } else {
3149             croak("sigset is not of type POSIX::SigSet");
3150         }
3151
3152         if (items < 3 || ! SvOK(ST(2))) {
3153             oldsigset = NULL;
3154         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
3155             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
3156         } else {
3157             croak("oldsigset is not of type POSIX::SigSet");
3158         }
3159
3160 void
3161 _exit(status)
3162         int             status
3163
3164 SysRet
3165 dup2(fd1, fd2)
3166         int             fd1
3167         int             fd2
3168     CODE:
3169         if (fd1 >= 0 && fd2 >= 0) {
3170 #ifdef WIN32
3171             /* RT #98912 - More Microsoft muppetry - failing to
3172                actually implemented the well known documented POSIX
3173                behaviour for a POSIX API.
3174                http://msdn.microsoft.com/en-us/library/8syseb29.aspx  */
3175             RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
3176 #else
3177             RETVAL = dup2(fd1, fd2);
3178 #endif
3179         } else {
3180             SETERRNO(EBADF,RMS_IFI);
3181             RETVAL = -1;
3182         }
3183     OUTPUT:
3184         RETVAL
3185
3186 SV *
3187 lseek(fd, offset, whence)
3188         POSIX::Fd       fd
3189         Off_t           offset
3190         int             whence
3191     CODE:
3192         {
3193               Off_t pos = PerlLIO_lseek(fd, offset, whence);
3194               RETVAL = sizeof(Off_t) > sizeof(IV)
3195                 ? newSVnv((NV)pos) : newSViv((IV)pos);
3196         }
3197     OUTPUT:
3198         RETVAL
3199
3200 void
3201 nice(incr)
3202         int             incr
3203     PPCODE:
3204         errno = 0;
3205         if ((incr = nice(incr)) != -1 || errno == 0) {
3206             if (incr == 0)
3207                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
3208             else
3209                 XPUSHs(sv_2mortal(newSViv(incr)));
3210         }
3211
3212 void
3213 pipe()
3214     PPCODE:
3215         int fds[2];
3216         if (pipe(fds) != -1) {
3217             EXTEND(SP,2);
3218             PUSHs(sv_2mortal(newSViv(fds[0])));
3219             PUSHs(sv_2mortal(newSViv(fds[1])));
3220         }
3221
3222 SysRet
3223 read(fd, buffer, nbytes)
3224     PREINIT:
3225         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3226     INPUT:
3227         POSIX::Fd       fd
3228         size_t          nbytes
3229         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
3230     CLEANUP:
3231         if (RETVAL >= 0) {
3232             SvCUR_set(sv_buffer, RETVAL);
3233             SvPOK_only(sv_buffer);
3234             *SvEND(sv_buffer) = '\0';
3235             SvTAINTED_on(sv_buffer);
3236         }
3237
3238 SysRet
3239 setpgid(pid, pgid)
3240         pid_t           pid
3241         pid_t           pgid
3242
3243 pid_t
3244 setsid()
3245
3246 pid_t
3247 tcgetpgrp(fd)
3248         POSIX::Fd       fd
3249
3250 SysRet
3251 tcsetpgrp(fd, pgrp_id)
3252         POSIX::Fd       fd
3253         pid_t           pgrp_id
3254
3255 void
3256 uname()
3257     PPCODE:
3258 #ifdef HAS_UNAME
3259         struct utsname buf;
3260         if (uname(&buf) >= 0) {
3261             EXTEND(SP, 5);
3262             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
3263             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
3264             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
3265             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
3266             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
3267         }
3268 #else
3269         uname((char *) 0); /* A stub to call not_here(). */
3270 #endif
3271
3272 SysRet
3273 write(fd, buffer, nbytes)
3274         POSIX::Fd       fd
3275         char *          buffer
3276         size_t          nbytes
3277
3278 void
3279 abort()
3280
3281 #ifdef I_WCHAR
3282 #  include <wchar.h>
3283 #endif
3284
3285 int
3286 mblen(s, n)
3287         char *          s
3288         size_t          n
3289     PREINIT:
3290 #if defined(USE_ITHREADS) && defined(HAS_MBRLEN)
3291         mbstate_t ps;
3292 #endif
3293     CODE:
3294 #if defined(USE_ITHREADS) && defined(HAS_MBRLEN)
3295         PERL_UNUSED_RESULT(mbrlen(NULL, 0, &ps));   /* Initialize state */
3296         RETVAL = mbrlen(s, n, &ps); /* Prefer reentrant version */
3297 #else
3298         RETVAL = mblen(s, n);
3299 #endif
3300     OUTPUT:
3301         RETVAL
3302
3303 size_t
3304 mbstowcs(s, pwcs, n)
3305         wchar_t *       s
3306         char *          pwcs
3307         size_t          n
3308
3309 int
3310 mbtowc(pwc, s, n)
3311         wchar_t *       pwc
3312         char *          s
3313         size_t          n
3314     PREINIT:
3315 #if defined(USE_ITHREADS) && defined(HAS_MBRTOWC)
3316         mbstate_t ps;
3317 #endif
3318     CODE:
3319 #if defined(USE_ITHREADS) && defined(HAS_MBRTOWC)
3320         memset(&ps, 0, sizeof(ps));;
3321         PERL_UNUSED_RESULT(mbrtowc(pwc, NULL, 0, &ps));/* Reset any shift state */
3322         errno = 0;
3323         RETVAL = mbrtowc(pwc, s, n, &ps);   /* Prefer reentrant version */
3324 #else
3325         RETVAL = mbtowc(pwc, s, n);
3326 #endif
3327     OUTPUT:
3328         RETVAL
3329
3330 int
3331 wcstombs(s, pwcs, n)
3332         char *          s
3333         wchar_t *       pwcs
3334         size_t          n
3335
3336 int
3337 wctomb(s, wchar)
3338         char *          s
3339         wchar_t         wchar
3340
3341 int
3342 strcoll(s1, s2)
3343         char *          s1
3344         char *          s2
3345
3346 void
3347 strtod(str)
3348         char *          str
3349     PREINIT:
3350         double num;
3351         char *unparsed;
3352     PPCODE:
3353         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3354         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3355         num = strtod(str, &unparsed);
3356         RESTORE_LC_NUMERIC();
3357         PUSHs(sv_2mortal(newSVnv(num)));
3358         if (GIMME_V == G_ARRAY) {
3359             EXTEND(SP, 1);
3360             if (unparsed)
3361                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3362             else
3363                 PUSHs(&PL_sv_undef);
3364         }
3365
3366 #ifdef HAS_STRTOLD
3367
3368 void
3369 strtold(str)
3370         char *          str
3371     PREINIT:
3372         long double num;
3373         char *unparsed;
3374     PPCODE:
3375         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3376         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3377         num = strtold(str, &unparsed);
3378         RESTORE_LC_NUMERIC();
3379         PUSHs(sv_2mortal(newSVnv(num)));
3380         if (GIMME_V == G_ARRAY) {
3381             EXTEND(SP, 1);
3382             if (unparsed)
3383                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3384             else
3385                 PUSHs(&PL_sv_undef);
3386         }
3387
3388 #endif
3389
3390 void
3391 strtol(str, base = 0)
3392         char *          str
3393         int             base
3394     PREINIT:
3395         long num;
3396         char *unparsed;
3397     PPCODE:
3398         if (base == 0 || (base >= 2 && base <= 36)) {
3399             num = strtol(str, &unparsed, base);
3400 #if IVSIZE < LONGSIZE
3401             if (num < IV_MIN || num > IV_MAX)
3402                 PUSHs(sv_2mortal(newSVnv((double)num)));
3403             else
3404 #endif
3405                 PUSHs(sv_2mortal(newSViv((IV)num)));
3406             if (GIMME_V == G_ARRAY) {
3407                 EXTEND(SP, 1);
3408                 if (unparsed)
3409                     PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3410                 else
3411                     PUSHs(&PL_sv_undef);
3412             }
3413         } else {
3414             SETERRNO(EINVAL, LIB_INVARG);
3415             PUSHs(&PL_sv_undef);
3416             if (GIMME_V == G_ARRAY) {
3417                EXTEND(SP, 1);
3418                PUSHs(&PL_sv_undef);
3419             }
3420         }
3421
3422 void
3423 strtoul(str, base = 0)
3424         const char *    str
3425         int             base
3426     PREINIT:
3427         unsigned long num;
3428         char *unparsed = NULL;
3429     PPCODE:
3430         PERL_UNUSED_VAR(str);
3431         PERL_UNUSED_VAR(base);
3432         if (base == 0 || (base >= 2 && base <= 36)) {
3433             num = strtoul(str, &unparsed, base);
3434 #if IVSIZE <= LONGSIZE
3435             if (num > IV_MAX)
3436                 PUSHs(sv_2mortal(newSVnv((double)num)));
3437             else
3438 #endif
3439                 PUSHs(sv_2mortal(newSViv((IV)num)));
3440             if (GIMME_V == G_ARRAY) {
3441                 EXTEND(SP, 1);
3442                 if (unparsed)
3443                     PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3444                 else
3445                   PUSHs(&PL_sv_undef);
3446             }
3447         } else {
3448             SETERRNO(EINVAL, LIB_INVARG);
3449             PUSHs(&PL_sv_undef);
3450             if (GIMME_V == G_ARRAY) {
3451                EXTEND(SP, 1);
3452                PUSHs(&PL_sv_undef);
3453             }
3454         }
3455
3456 void
3457 strxfrm(src)
3458         SV *            src
3459     CODE:
3460         {
3461           STRLEN srclen;
3462           STRLEN dstlen;
3463           STRLEN buflen;
3464           char *p = SvPV(src,srclen);
3465           srclen++;
3466           buflen = srclen * 4 + 1;
3467           ST(0) = sv_2mortal(newSV(buflen));
3468           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen);
3469           if (dstlen >= buflen) {
3470               dstlen++;
3471               SvGROW(ST(0), dstlen);
3472               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
3473               dstlen--;
3474           }
3475           SvCUR_set(ST(0), dstlen);
3476             SvPOK_only(ST(0));
3477         }
3478
3479 SysRet
3480 mkfifo(filename, mode)
3481         char *          filename
3482         Mode_t          mode
3483     ALIAS:
3484         access = 1
3485     CODE:
3486         if(ix) {
3487             RETVAL = access(filename, mode);
3488         } else {
3489             TAINT_PROPER("mkfifo");
3490             RETVAL = mkfifo(filename, mode);
3491         }
3492     OUTPUT:
3493         RETVAL
3494
3495 SysRet
3496 tcdrain(fd)
3497         POSIX::Fd       fd
3498     ALIAS:
3499         close = 1
3500         dup = 2
3501     CODE:
3502         if (fd >= 0) {
3503             RETVAL = ix == 1 ? close(fd)
3504               : (ix < 1 ? tcdrain(fd) : dup(fd));
3505         } else {
3506             SETERRNO(EBADF,RMS_IFI);
3507             RETVAL = -1;
3508         }
3509     OUTPUT:
3510         RETVAL
3511
3512
3513 SysRet
3514 tcflow(fd, action)
3515         POSIX::Fd       fd
3516         int             action
3517     ALIAS:
3518         tcflush = 1
3519         tcsendbreak = 2
3520     CODE:
3521         if (action >= 0) {
3522             RETVAL = ix == 1 ? tcflush(fd, action)
3523               : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
3524         } else {
3525             SETERRNO(EINVAL,LIB_INVARG);
3526             RETVAL = -1;
3527         }
3528     OUTPUT:
3529         RETVAL
3530
3531 void
3532 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
3533         int             sec
3534         int             min
3535         int             hour
3536         int             mday
3537         int             mon
3538         int             year
3539         int             wday
3540         int             yday
3541         int             isdst
3542     ALIAS:
3543         mktime = 1
3544     PPCODE:
3545         {
3546             dXSTARG;
3547             struct tm mytm;
3548             init_tm(&mytm);     /* XXX workaround - see init_tm() in core util.c */
3549             mytm.tm_sec = sec;
3550             mytm.tm_min = min;
3551             mytm.tm_hour = hour;
3552             mytm.tm_mday = mday;
3553             mytm.tm_mon = mon;
3554             mytm.tm_year = year;
3555             mytm.tm_wday = wday;
3556             mytm.tm_yday = yday;
3557             mytm.tm_isdst = isdst;
3558             if (ix) {
3559                 const time_t result = mktime(&mytm);
3560                 if (result == (time_t)-1)
3561                     SvOK_off(TARG);
3562                 else if (result == 0)
3563                     sv_setpvs(TARG, "0 but true");
3564                 else
3565                     sv_setiv(TARG, (IV)result);
3566             } else {
3567                 sv_setpv(TARG, asctime(&mytm));
3568             }
3569             ST(0) = TARG;
3570             XSRETURN(1);
3571         }
3572
3573 long
3574 clock()
3575
3576 char *
3577 ctime(time)
3578         Time_t          &time
3579
3580 void
3581 times()
3582         PPCODE:
3583         struct tms tms;
3584         clock_t realtime;
3585         realtime = times( &tms );
3586         EXTEND(SP,5);
3587         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
3588         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
3589         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
3590         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
3591         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
3592
3593 double
3594 difftime(time1, time2)
3595         Time_t          time1
3596         Time_t          time2
3597
3598 #XXX: if $xsubpp::WantOptimize is always the default
3599 #     sv_setpv(TARG, ...) could be used rather than
3600 #     ST(0) = sv_2mortal(newSVpv(...))
3601 void
3602 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
3603         SV *            fmt
3604         int             sec
3605         int             min
3606         int             hour
3607         int             mday
3608         int             mon
3609         int             year
3610         int             wday
3611         int             yday
3612         int             isdst
3613     CODE:
3614         {
3615             char *buf;
3616             SV *sv;
3617
3618             /* allowing user-supplied (rather than literal) formats
3619              * is normally frowned upon as a potential security risk;
3620              * but this is part of the API so we have to allow it */
3621             GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
3622             buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
3623             GCC_DIAG_RESTORE_STMT;
3624             sv = sv_newmortal();
3625             if (buf) {
3626                 STRLEN len = strlen(buf);
3627                 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL);
3628                 if (       SvUTF8(fmt)
3629                     || (   is_utf8_non_invariant_string((U8*) buf, len)
3630 #ifdef USE_LOCALE_TIME
3631                         && _is_cur_LC_category_utf8(LC_TIME)
3632 #else   /* If can't check directly, at least can see if script is consistent,
3633            under UTF-8, which gives us an extra measure of confidence. */
3634
3635                         && isSCRIPT_RUN((const U8 *) buf, buf + len,
3636                                         TRUE, /* Means assume UTF-8 */
3637                                         NULL)
3638 #endif
3639                 )) {
3640                     SvUTF8_on(sv);
3641                 }
3642             }
3643             else {  /* We can't distinguish between errors and just an empty
3644                      * return; in all cases just return an empty string */
3645                 SvUPGRADE(sv, SVt_PV);
3646                 SvPV_set(sv, (char *) "");
3647                 SvPOK_on(sv);
3648                 SvCUR_set(sv, 0);
3649                 SvLEN_set(sv, 0);   /* Won't attempt to free the string when sv
3650                                        gets destroyed */
3651             }
3652             ST(0) = sv;
3653         }
3654
3655 void
3656 tzset()
3657   PPCODE:
3658     my_tzset(aTHX);
3659
3660 void
3661 tzname()
3662     PPCODE:
3663         EXTEND(SP,2);
3664         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
3665         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
3666
3667 char *
3668 ctermid(s = 0)
3669         char *          s = 0;
3670     CODE:
3671 #ifdef HAS_CTERMID_R
3672         s = (char *) safemalloc((size_t) L_ctermid);
3673 #endif
3674         RETVAL = ctermid(s);
3675     OUTPUT:
3676         RETVAL
3677     CLEANUP:
3678 #ifdef HAS_CTERMID_R
3679         Safefree(s);
3680 #endif
3681
3682 char *
3683 cuserid(s = 0)
3684         char *          s = 0;
3685     CODE:
3686 #ifdef HAS_CUSERID
3687   RETVAL = cuserid(s);
3688 #else
3689   PERL_UNUSED_VAR(s);
3690   RETVAL = 0;
3691   not_here("cuserid");
3692 #endif
3693     OUTPUT:
3694   RETVAL
3695
3696 SysRetLong
3697 fpathconf(fd, name)
3698         POSIX::Fd       fd
3699         int             name
3700
3701 SysRetLong
3702 pathconf(filename, name)
3703         char *          filename
3704         int             name
3705
3706 SysRet
3707 pause()
3708     CLEANUP:
3709     PERL_ASYNC_CHECK();
3710
3711 unsigned int
3712 sleep(seconds)
3713         unsigned int    seconds
3714     CODE:
3715         RETVAL = PerlProc_sleep(seconds);
3716     OUTPUT:
3717         RETVAL
3718
3719 SysRet
3720 setgid(gid)
3721         Gid_t           gid
3722
3723 SysRet
3724 setuid(uid)
3725         Uid_t           uid
3726
3727 SysRetLong
3728 sysconf(name)
3729         int             name
3730
3731 char *
3732 ttyname(fd)
3733         POSIX::Fd       fd
3734
3735 void
3736 getcwd()
3737     PPCODE:
3738       {
3739         dXSTARG;
3740         getcwd_sv(TARG);
3741         XSprePUSH; PUSHTARG;
3742       }
3743
3744 SysRet
3745 lchown(uid, gid, path)
3746        Uid_t           uid
3747        Gid_t           gid
3748        char *          path
3749     CODE:
3750 #ifdef HAS_LCHOWN
3751        /* yes, the order of arguments is different,
3752         * but consistent with CORE::chown() */
3753        RETVAL = lchown(path, uid, gid);
3754 #else
3755        PERL_UNUSED_VAR(uid);
3756        PERL_UNUSED_VAR(gid);
3757        PERL_UNUSED_VAR(path);
3758        RETVAL = not_here("lchown");
3759 #endif
3760     OUTPUT:
3761        RETVAL