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