This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7b9d0566c75d910f2ae9b2e979e7bd7238553a70
[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 #  if LONG_DOUBLESIZE > 10
1233   memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */
1234 #  endif
1235 # endif
1236 #endif
1237   for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
1238     if (a[i]) {
1239       Perl_warn(aTHX_ "payload lost bits (%"UVxf")", a[i]);
1240       break;
1241     }
1242   }
1243 #ifdef NV_PAYLOAD_DEBUG
1244   for (i = 0; i < NVSIZE; i++) {
1245     PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]);
1246   }
1247   PerlIO_printf(Perl_debug_log, "\n");
1248 #endif
1249 }
1250
1251 static NV_PAYLOAD_TYPE S_getpayload(NV nv)
1252 {
1253   dTHX;
1254   static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1255   static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1256   UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1257   int i;
1258   NV payload;
1259   NV_PAYLOAD_SIZEOF_ASSERT(m);
1260   NV_PAYLOAD_SIZEOF_ASSERT(p);
1261   payload = 0;
1262   for (i = 0; i < (int)sizeof(p); i++) {
1263     if (m[i] && p[i] < NVSIZE) {
1264       U8 s = (p[i] % UVSIZE) << 3;
1265       a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s;
1266     }
1267   }
1268   for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) {
1269 #ifdef NV_PAYLOAD_DEBUG
1270     Perl_warn(aTHX_ "a[%d] = %"UVxf"\n", i, a[i]);
1271 #endif
1272     payload *= UV_MAX;
1273     payload += a[i];
1274   }
1275 #ifdef NV_PAYLOAD_DEBUG
1276   for (i = 0; i < NVSIZE; i++) {
1277     PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]);
1278   }
1279   PerlIO_printf(Perl_debug_log, "\n");
1280 #endif
1281   return payload;
1282 }
1283
1284 /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
1285    metaconfig for future extension writers.  We don't use them in POSIX.
1286    (This is really sneaky :-)  --AD
1287 */
1288 #if defined(I_TERMIOS)
1289 #include <termios.h>
1290 #endif
1291 #ifdef I_STDLIB
1292 #include <stdlib.h>
1293 #endif
1294 #ifndef __ultrix__
1295 #include <string.h>
1296 #endif
1297 #include <sys/stat.h>
1298 #include <sys/types.h>
1299 #include <time.h>
1300 #ifdef I_UNISTD
1301 #include <unistd.h>
1302 #endif
1303 #include <fcntl.h>
1304
1305 #ifdef HAS_TZNAME
1306 #  if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__)
1307 extern char *tzname[];
1308 #  endif
1309 #else
1310 #if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname))
1311 char *tzname[] = { "" , "" };
1312 #endif
1313 #endif
1314
1315 #if defined(__VMS) && !defined(__POSIX_SOURCE)
1316
1317 #  include <utsname.h>
1318
1319 #  undef mkfifo
1320 #  define mkfifo(a,b) (not_here("mkfifo"),-1)
1321
1322    /* The POSIX notion of ttyname() is better served by getname() under VMS */
1323    static char ttnambuf[64];
1324 #  define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
1325
1326 #else
1327 #if defined (__CYGWIN__)
1328 #    define tzname _tzname
1329 #endif
1330 #if defined (WIN32) || defined (NETWARE)
1331 #  undef mkfifo
1332 #  define mkfifo(a,b) not_here("mkfifo")
1333 #  define ttyname(a) (char*)not_here("ttyname")
1334 #  define sigset_t long
1335 #  define pid_t long
1336 #  ifdef _MSC_VER
1337 #    define mode_t short
1338 #  endif
1339 #  ifdef __MINGW32__
1340 #    define mode_t short
1341 #    ifndef tzset
1342 #      define tzset()           not_here("tzset")
1343 #    endif
1344 #    ifndef _POSIX_OPEN_MAX
1345 #      define _POSIX_OPEN_MAX   FOPEN_MAX       /* XXX bogus ? */
1346 #    endif
1347 #  endif
1348 #  define sigaction(a,b,c)      not_here("sigaction")
1349 #  define sigpending(a)         not_here("sigpending")
1350 #  define sigprocmask(a,b,c)    not_here("sigprocmask")
1351 #  define sigsuspend(a)         not_here("sigsuspend")
1352 #  define sigemptyset(a)        not_here("sigemptyset")
1353 #  define sigaddset(a,b)        not_here("sigaddset")
1354 #  define sigdelset(a,b)        not_here("sigdelset")
1355 #  define sigfillset(a)         not_here("sigfillset")
1356 #  define sigismember(a,b)      not_here("sigismember")
1357 #ifndef NETWARE
1358 #  undef setuid
1359 #  undef setgid
1360 #  define setuid(a)             not_here("setuid")
1361 #  define setgid(a)             not_here("setgid")
1362 #endif  /* NETWARE */
1363 #ifndef USE_LONG_DOUBLE
1364 #  define strtold(s1,s2)        not_here("strtold")
1365 #endif  /* USE_LONG_DOUBLE */
1366 #else
1367
1368 #  ifndef HAS_MKFIFO
1369 #    if defined(OS2) || defined(__amigaos4__)
1370 #      define mkfifo(a,b) not_here("mkfifo")
1371 #    else       /* !( defined OS2 ) */
1372 #      ifndef mkfifo
1373 #        define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
1374 #      endif
1375 #    endif
1376 #  endif /* !HAS_MKFIFO */
1377
1378 #  ifdef I_GRP
1379 #    include <grp.h>
1380 #  endif
1381 #  include <sys/times.h>
1382 #  ifdef HAS_UNAME
1383 #    include <sys/utsname.h>
1384 #  endif
1385 #  ifndef __amigaos4__
1386 #    include <sys/wait.h>
1387 #  endif
1388 #  ifdef I_UTIME
1389 #    include <utime.h>
1390 #  endif
1391 #endif /* WIN32 || NETWARE */
1392 #endif /* __VMS */
1393
1394 typedef int SysRet;
1395 typedef long SysRetLong;
1396 typedef sigset_t* POSIX__SigSet;
1397 typedef HV* POSIX__SigAction;
1398 typedef int POSIX__SigNo;
1399 #ifdef I_TERMIOS
1400 typedef struct termios* POSIX__Termios;
1401 #else /* Define termios types to int, and call not_here for the functions.*/
1402 #define POSIX__Termios int
1403 #define speed_t int
1404 #define tcflag_t int
1405 #define cc_t int
1406 #define cfgetispeed(x) not_here("cfgetispeed")
1407 #define cfgetospeed(x) not_here("cfgetospeed")
1408 #define tcdrain(x) not_here("tcdrain")
1409 #define tcflush(x,y) not_here("tcflush")
1410 #define tcsendbreak(x,y) not_here("tcsendbreak")
1411 #define cfsetispeed(x,y) not_here("cfsetispeed")
1412 #define cfsetospeed(x,y) not_here("cfsetospeed")
1413 #define ctermid(x) (char *) not_here("ctermid")
1414 #define tcflow(x,y) not_here("tcflow")
1415 #define tcgetattr(x,y) not_here("tcgetattr")
1416 #define tcsetattr(x,y,z) not_here("tcsetattr")
1417 #endif
1418
1419 /* Possibly needed prototypes */
1420 #ifndef WIN32
1421 START_EXTERN_C
1422 double strtod (const char *, char **);
1423 long strtol (const char *, char **, int);
1424 unsigned long strtoul (const char *, char **, int);
1425 #ifdef HAS_STRTOLD
1426 long double strtold (const char *, char **);
1427 #endif
1428 END_EXTERN_C
1429 #endif
1430
1431 #ifndef HAS_DIFFTIME
1432 #ifndef difftime
1433 #define difftime(a,b) not_here("difftime")
1434 #endif
1435 #endif
1436 #ifndef HAS_FPATHCONF
1437 #define fpathconf(f,n)  (SysRetLong) not_here("fpathconf")
1438 #endif
1439 #ifndef HAS_MKTIME
1440 #define mktime(a) not_here("mktime")
1441 #endif
1442 #ifndef HAS_NICE
1443 #define nice(a) not_here("nice")
1444 #endif
1445 #ifndef HAS_PATHCONF
1446 #define pathconf(f,n)   (SysRetLong) not_here("pathconf")
1447 #endif
1448 #ifndef HAS_SYSCONF
1449 #define sysconf(n)      (SysRetLong) not_here("sysconf")
1450 #endif
1451 #ifndef HAS_READLINK
1452 #define readlink(a,b,c) not_here("readlink")
1453 #endif
1454 #ifndef HAS_SETPGID
1455 #define setpgid(a,b) not_here("setpgid")
1456 #endif
1457 #ifndef HAS_SETSID
1458 #define setsid() not_here("setsid")
1459 #endif
1460 #ifndef HAS_STRCOLL
1461 #define strcoll(s1,s2) not_here("strcoll")
1462 #endif
1463 #ifndef HAS_STRTOD
1464 #define strtod(s1,s2) not_here("strtod")
1465 #endif
1466 #ifndef HAS_STRTOLD
1467 #define strtold(s1,s2) not_here("strtold")
1468 #endif
1469 #ifndef HAS_STRTOL
1470 #define strtol(s1,s2,b) not_here("strtol")
1471 #endif
1472 #ifndef HAS_STRTOUL
1473 #define strtoul(s1,s2,b) not_here("strtoul")
1474 #endif
1475 #ifndef HAS_STRXFRM
1476 #define strxfrm(s1,s2,n) not_here("strxfrm")
1477 #endif
1478 #ifndef HAS_TCGETPGRP
1479 #define tcgetpgrp(a) not_here("tcgetpgrp")
1480 #endif
1481 #ifndef HAS_TCSETPGRP
1482 #define tcsetpgrp(a,b) not_here("tcsetpgrp")
1483 #endif
1484 #ifndef HAS_TIMES
1485 #ifndef NETWARE
1486 #define times(a) not_here("times")
1487 #endif  /* NETWARE */
1488 #endif
1489 #ifndef HAS_UNAME
1490 #define uname(a) not_here("uname")
1491 #endif
1492 #ifndef HAS_WAITPID
1493 #define waitpid(a,b,c) not_here("waitpid")
1494 #endif
1495
1496 #ifndef HAS_MBLEN
1497 #ifndef mblen
1498 #define mblen(a,b) not_here("mblen")
1499 #endif
1500 #endif
1501 #ifndef HAS_MBSTOWCS
1502 #define mbstowcs(s, pwcs, n) not_here("mbstowcs")
1503 #endif
1504 #ifndef HAS_MBTOWC
1505 #define mbtowc(pwc, s, n) not_here("mbtowc")
1506 #endif
1507 #ifndef HAS_WCSTOMBS
1508 #define wcstombs(s, pwcs, n) not_here("wcstombs")
1509 #endif
1510 #ifndef HAS_WCTOMB
1511 #define wctomb(s, wchar) not_here("wcstombs")
1512 #endif
1513 #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
1514 /* If we don't have these functions, then we wouldn't have gotten a typedef
1515    for wchar_t, the wide character type.  Defining wchar_t allows the
1516    functions referencing it to compile.  Its actual type is then meaningless,
1517    since without the above functions, all sections using it end up calling
1518    not_here() and croak.  --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
1519 #ifndef wchar_t
1520 #define wchar_t char
1521 #endif
1522 #endif
1523
1524 #ifndef HAS_LOCALECONV
1525 #   define localeconv() not_here("localeconv")
1526 #else
1527 struct lconv_offset {
1528     const char *name;
1529     size_t offset;
1530 };
1531
1532 static const struct lconv_offset lconv_strings[] = {
1533 #ifdef USE_LOCALE_NUMERIC
1534     {"decimal_point",     STRUCT_OFFSET(struct lconv, decimal_point)},
1535     {"thousands_sep",     STRUCT_OFFSET(struct lconv, thousands_sep)},
1536 #  ifndef NO_LOCALECONV_GROUPING
1537     {"grouping",          STRUCT_OFFSET(struct lconv, grouping)},
1538 #  endif
1539 #endif
1540 #ifdef USE_LOCALE_MONETARY
1541     {"int_curr_symbol",   STRUCT_OFFSET(struct lconv, int_curr_symbol)},
1542     {"currency_symbol",   STRUCT_OFFSET(struct lconv, currency_symbol)},
1543     {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)},
1544 #  ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
1545     {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)},
1546 #  endif
1547 #  ifndef NO_LOCALECONV_MON_GROUPING
1548     {"mon_grouping",      STRUCT_OFFSET(struct lconv, mon_grouping)},
1549 #  endif
1550     {"positive_sign",     STRUCT_OFFSET(struct lconv, positive_sign)},
1551     {"negative_sign",     STRUCT_OFFSET(struct lconv, negative_sign)},
1552 #endif
1553     {NULL, 0}
1554 };
1555
1556 #ifdef USE_LOCALE_NUMERIC
1557
1558 /* The Linux man pages say these are the field names for the structure
1559  * components that are LC_NUMERIC; the rest being LC_MONETARY */
1560 #   define isLC_NUMERIC_STRING(name) (strcmp(name, "decimal_point")     \
1561                                       || strcmp(name, "thousands_sep")  \
1562                                                                         \
1563                                       /* There should be no harm done   \
1564                                        * checking for this, even if     \
1565                                        * NO_LOCALECONV_GROUPING */      \
1566                                       || strcmp(name, "grouping"))
1567 #else
1568 #   define isLC_NUMERIC_STRING(name) (0)
1569 #endif
1570
1571 static const struct lconv_offset lconv_integers[] = {
1572 #ifdef USE_LOCALE_MONETARY
1573     {"int_frac_digits",   STRUCT_OFFSET(struct lconv, int_frac_digits)},
1574     {"frac_digits",       STRUCT_OFFSET(struct lconv, frac_digits)},
1575     {"p_cs_precedes",     STRUCT_OFFSET(struct lconv, p_cs_precedes)},
1576     {"p_sep_by_space",    STRUCT_OFFSET(struct lconv, p_sep_by_space)},
1577     {"n_cs_precedes",     STRUCT_OFFSET(struct lconv, n_cs_precedes)},
1578     {"n_sep_by_space",    STRUCT_OFFSET(struct lconv, n_sep_by_space)},
1579     {"p_sign_posn",       STRUCT_OFFSET(struct lconv, p_sign_posn)},
1580     {"n_sign_posn",       STRUCT_OFFSET(struct lconv, n_sign_posn)},
1581 #ifdef HAS_LC_MONETARY_2008
1582     {"int_p_cs_precedes",  STRUCT_OFFSET(struct lconv, int_p_cs_precedes)},
1583     {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)},
1584     {"int_n_cs_precedes",  STRUCT_OFFSET(struct lconv, int_n_cs_precedes)},
1585     {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)},
1586     {"int_p_sign_posn",    STRUCT_OFFSET(struct lconv, int_p_sign_posn)},
1587     {"int_n_sign_posn",    STRUCT_OFFSET(struct lconv, int_n_sign_posn)},
1588 #endif
1589 #endif
1590     {NULL, 0}
1591 };
1592
1593 #endif /* HAS_LOCALECONV */
1594
1595 #ifdef HAS_LONG_DOUBLE
1596 #  if LONG_DOUBLESIZE > NVSIZE
1597 #    undef HAS_LONG_DOUBLE  /* XXX until we figure out how to use them */
1598 #  endif
1599 #endif
1600
1601 #ifndef HAS_LONG_DOUBLE
1602 #ifdef LDBL_MAX
1603 #undef LDBL_MAX
1604 #endif
1605 #ifdef LDBL_MIN
1606 #undef LDBL_MIN
1607 #endif
1608 #ifdef LDBL_EPSILON
1609 #undef LDBL_EPSILON
1610 #endif
1611 #endif
1612
1613 /* Background: in most systems the low byte of the wait status
1614  * is the signal (the lowest 7 bits) and the coredump flag is
1615  * the eight bit, and the second lowest byte is the exit status.
1616  * BeOS bucks the trend and has the bytes in different order.
1617  * See beos/beos.c for how the reality is bent even in BeOS
1618  * to follow the traditional.  However, to make the POSIX
1619  * wait W*() macros to work in BeOS, we need to unbend the
1620  * reality back in place. --jhi */
1621 /* In actual fact the code below is to blame here. Perl has an internal
1622  * representation of the exit status ($?), which it re-composes from the
1623  * OS's representation using the W*() POSIX macros. The code below
1624  * incorrectly uses the W*() macros on the internal representation,
1625  * which fails for OSs that have a different representation (namely BeOS
1626  * and Haiku). WMUNGE() is a hack that converts the internal
1627  * representation into the OS specific one, so that the W*() macros work
1628  * as expected. The better solution would be not to use the W*() macros
1629  * in the first place, though. -- Ingo Weinhold
1630  */
1631 #if defined(__HAIKU__)
1632 #    define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
1633 #else
1634 #    define WMUNGE(x) (x)
1635 #endif
1636
1637 static int
1638 not_here(const char *s)
1639 {
1640     croak("POSIX::%s not implemented on this architecture", s);
1641     return -1;
1642 }
1643
1644 #include "const-c.inc"
1645
1646 static void
1647 restore_sigmask(pTHX_ SV *osset_sv)
1648 {
1649      /* Fortunately, restoring the signal mask can't fail, because
1650       * there's nothing we can do about it if it does -- we're not
1651       * supposed to return -1 from sigaction unless the disposition
1652       * was unaffected.
1653       */
1654 #if !(defined(__amigaos4__) && defined(__NEWLIB__))
1655      sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
1656      (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1657 #endif
1658 }
1659
1660 static void *
1661 allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
1662     SV *const t = newSVrv(rv, packname);
1663     void *const p = sv_grow(t, size + 1);
1664
1665     SvCUR_set(t, size);
1666     SvPOK_on(t);
1667     return p;
1668 }
1669
1670 #ifdef WIN32
1671
1672 /*
1673  * (1) The CRT maintains its own copy of the environment, separate from
1674  * the Win32API copy.
1675  *
1676  * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
1677  * copy, and then calls SetEnvironmentVariableA() to update the Win32API
1678  * copy.
1679  *
1680  * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
1681  * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
1682  * environment.
1683  *
1684  * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
1685  * calls CRT tzset(), but only the first time it is called, and in turn
1686  * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
1687  * local copy of the environment and hence gets the original setting as
1688  * perl never updates the CRT copy when assigning to $ENV{TZ}.
1689  *
1690  * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
1691  * putenv() to update the CRT copy of the environment (if it is different)
1692  * whenever we're about to call tzset().
1693  *
1694  * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
1695  * defined:
1696  *
1697  * (a) Each interpreter has its own copy of the environment inside the
1698  * perlhost structure. That allows applications that host multiple
1699  * independent Perl interpreters to isolate environment changes from
1700  * each other. (This is similar to how the perlhost mechanism keeps a
1701  * separate working directory for each Perl interpreter, so that calling
1702  * chdir() will not affect other interpreters.)
1703  *
1704  * (b) Only the first Perl interpreter instantiated within a process will
1705  * "write through" environment changes to the process environment.
1706  *
1707  * (c) Even the primary Perl interpreter won't update the CRT copy of the
1708  * the environment, only the Win32API copy (it calls win32_putenv()).
1709  *
1710  * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
1711  * sense to only update the process environment when inside the main
1712  * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
1713  * from here so we'll just have to check PL_curinterp instead.
1714  *
1715  * Therefore, we can simply #undef getenv() and putenv() so that those names
1716  * always refer to the CRT functions, and explicitly call win32_getenv() to
1717  * access perl's %ENV.
1718  *
1719  * We also #undef malloc() and free() to be sure we are using the CRT
1720  * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
1721  * into VMem::Malloc() and VMem::Free() and all allocations will be freed
1722  * when the Perl interpreter is being destroyed so we'd end up with a pointer
1723  * into deallocated memory in environ[] if a program embedding a Perl
1724  * interpreter continues to operate even after the main Perl interpreter has
1725  * been destroyed.
1726  *
1727  * Note that we don't free() the malloc()ed memory unless and until we call
1728  * malloc() again ourselves because the CRT putenv() function simply puts its
1729  * pointer argument into the environ[] array (it doesn't make a copy of it)
1730  * so this memory must otherwise be leaked.
1731  */
1732
1733 #undef getenv
1734 #undef putenv
1735 #undef malloc
1736 #undef free
1737
1738 static void
1739 fix_win32_tzenv(void)
1740 {
1741     static char* oldenv = NULL;
1742     char* newenv;
1743     const char* perl_tz_env = win32_getenv("TZ");
1744     const char* crt_tz_env = getenv("TZ");
1745     if (perl_tz_env == NULL)
1746         perl_tz_env = "";
1747     if (crt_tz_env == NULL)
1748         crt_tz_env = "";
1749     if (strcmp(perl_tz_env, crt_tz_env) != 0) {
1750         newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
1751         if (newenv != NULL) {
1752             sprintf(newenv, "TZ=%s", perl_tz_env);
1753             putenv(newenv);
1754             if (oldenv != NULL)
1755                 free(oldenv);
1756             oldenv = newenv;
1757         }
1758     }
1759 }
1760
1761 #endif
1762
1763 /*
1764  * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
1765  * This code is duplicated in the Time-Piece module, so any changes made here
1766  * should be made there too.
1767  */
1768 static void
1769 my_tzset(pTHX)
1770 {
1771 #ifdef WIN32
1772 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
1773     if (PL_curinterp == aTHX)
1774 #endif
1775         fix_win32_tzenv();
1776 #endif
1777     tzset();
1778 }
1779
1780 typedef int (*isfunc_t)(int);
1781 typedef void (*any_dptr_t)(void *);
1782
1783 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
1784    a regular XSUB.  */
1785 static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */
1786 static XSPROTO(is_common)
1787 {
1788     dXSARGS;
1789
1790     if (items != 1)
1791        croak_xs_usage(cv,  "charstring");
1792
1793     {
1794         dXSTARG;
1795         STRLEN  len;
1796         /*int   RETVAL = 0;   YYY means uncomment this to return false on an
1797                             * empty string input */
1798         int     RETVAL;
1799         unsigned char *s = (unsigned char *) SvPV(ST(0), len);
1800         unsigned char *e = s + len;
1801         isfunc_t isfunc = (isfunc_t) XSANY.any_dptr;
1802
1803         if (ckWARN_d(WARN_DEPRECATED)) {
1804
1805             /* Warn exactly once for each lexical place this function is
1806              * called.  See thread at
1807              * http://markmail.org/thread/jhqcag5njmx7jpyu */
1808
1809             HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI);
1810             if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) {
1811                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
1812                             "Calling POSIX::%"HEKf"() is deprecated",
1813                             HEKfARG(GvNAME_HEK(CvGV(cv))));
1814                 (void)hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0);
1815             }
1816         }
1817
1818         /*if (e > s) { YYY */
1819         for (RETVAL = 1; RETVAL && s < e; s++)
1820             if (!isfunc(*s))
1821                 RETVAL = 0;
1822         /*} YYY */
1823         XSprePUSH;
1824         PUSHi((IV)RETVAL);
1825     }
1826     XSRETURN(1);
1827 }
1828
1829 MODULE = POSIX          PACKAGE = POSIX
1830
1831 BOOT:
1832 {
1833     CV *cv;
1834
1835
1836     /* silence compiler warning about not_here() defined but not used */
1837     if (0) not_here("");
1838
1839     /* Ensure we get the function, not a macro implementation. Like the C89
1840        standard says we can...  */
1841 #undef isalnum
1842     cv = newXS_deffile("POSIX::isalnum", is_common);
1843     XSANY.any_dptr = (any_dptr_t) &isalnum;
1844 #undef isalpha
1845     cv = newXS_deffile("POSIX::isalpha", is_common);
1846     XSANY.any_dptr = (any_dptr_t) &isalpha;
1847 #undef iscntrl
1848     cv = newXS_deffile("POSIX::iscntrl", is_common);
1849     XSANY.any_dptr = (any_dptr_t) &iscntrl;
1850 #undef isdigit
1851     cv = newXS_deffile("POSIX::isdigit", is_common);
1852     XSANY.any_dptr = (any_dptr_t) &isdigit;
1853 #undef isgraph
1854     cv = newXS_deffile("POSIX::isgraph", is_common);
1855     XSANY.any_dptr = (any_dptr_t) &isgraph;
1856 #undef islower
1857     cv = newXS_deffile("POSIX::islower", is_common);
1858     XSANY.any_dptr = (any_dptr_t) &islower;
1859 #undef isprint
1860     cv = newXS_deffile("POSIX::isprint", is_common);
1861     XSANY.any_dptr = (any_dptr_t) &isprint;
1862 #undef ispunct
1863     cv = newXS_deffile("POSIX::ispunct", is_common);
1864     XSANY.any_dptr = (any_dptr_t) &ispunct;
1865 #undef isspace
1866     cv = newXS_deffile("POSIX::isspace", is_common);
1867     XSANY.any_dptr = (any_dptr_t) &isspace;
1868 #undef isupper
1869     cv = newXS_deffile("POSIX::isupper", is_common);
1870     XSANY.any_dptr = (any_dptr_t) &isupper;
1871 #undef isxdigit
1872     cv = newXS_deffile("POSIX::isxdigit", is_common);
1873     XSANY.any_dptr = (any_dptr_t) &isxdigit;
1874 }
1875
1876 MODULE = SigSet         PACKAGE = POSIX::SigSet         PREFIX = sig
1877
1878 void
1879 new(packname = "POSIX::SigSet", ...)
1880     const char *        packname
1881     CODE:
1882         {
1883             int i;
1884             sigset_t *const s
1885                 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1886                                                sizeof(sigset_t),
1887                                                packname);
1888             sigemptyset(s);
1889             for (i = 1; i < items; i++)
1890                 sigaddset(s, SvIV(ST(i)));
1891             XSRETURN(1);
1892         }
1893
1894 SysRet
1895 addset(sigset, sig)
1896         POSIX::SigSet   sigset
1897         POSIX::SigNo    sig
1898    ALIAS:
1899         delset = 1
1900    CODE:
1901         RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
1902    OUTPUT:
1903         RETVAL
1904
1905 SysRet
1906 emptyset(sigset)
1907         POSIX::SigSet   sigset
1908    ALIAS:
1909         fillset = 1
1910    CODE:
1911         RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
1912    OUTPUT:
1913         RETVAL
1914
1915 int
1916 sigismember(sigset, sig)
1917         POSIX::SigSet   sigset
1918         POSIX::SigNo    sig
1919
1920 MODULE = Termios        PACKAGE = POSIX::Termios        PREFIX = cf
1921
1922 void
1923 new(packname = "POSIX::Termios", ...)
1924     const char *        packname
1925     CODE:
1926         {
1927 #ifdef I_TERMIOS
1928             void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1929                                             sizeof(struct termios), packname);
1930             /* The previous implementation stored a pointer to an uninitialised
1931                struct termios. Seems safer to initialise it, particularly as
1932                this implementation exposes the struct to prying from perl-space.
1933             */
1934             memset(p, 0, 1 + sizeof(struct termios));
1935             XSRETURN(1);
1936 #else
1937             not_here("termios");
1938 #endif
1939         }
1940
1941 SysRet
1942 getattr(termios_ref, fd = 0)
1943         POSIX::Termios  termios_ref
1944         int             fd
1945     CODE:
1946         RETVAL = tcgetattr(fd, termios_ref);
1947     OUTPUT:
1948         RETVAL
1949
1950 # If we define TCSANOW here then both a found and not found constant sub
1951 # are created causing a Constant subroutine TCSANOW redefined warning
1952 #ifndef TCSANOW
1953 #  define DEF_SETATTR_ACTION 0
1954 #else
1955 #  define DEF_SETATTR_ACTION TCSANOW
1956 #endif
1957 SysRet
1958 setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
1959         POSIX::Termios  termios_ref
1960         int             fd
1961         int             optional_actions
1962     CODE:
1963         if (fd >= 0) {
1964             /* The second argument to the call is mandatory, but we'd like to give
1965                it a useful default. 0 isn't valid on all operating systems - on
1966                Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
1967                values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF.  */
1968             if (optional_actions < 0) {
1969                SETERRNO(EINVAL, LIB_INVARG);
1970                RETVAL = -1;
1971             } else {
1972                 RETVAL = tcsetattr(fd, optional_actions, termios_ref);
1973             }
1974         } else {
1975             SETERRNO(EBADF,RMS_IFI);
1976             RETVAL = -1;
1977         }
1978     OUTPUT:
1979         RETVAL
1980
1981 speed_t
1982 getispeed(termios_ref)
1983         POSIX::Termios  termios_ref
1984     ALIAS:
1985         getospeed = 1
1986     CODE:
1987         RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
1988     OUTPUT:
1989         RETVAL
1990
1991 tcflag_t
1992 getiflag(termios_ref)
1993         POSIX::Termios  termios_ref
1994     ALIAS:
1995         getoflag = 1
1996         getcflag = 2
1997         getlflag = 3
1998     CODE:
1999 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2000         switch(ix) {
2001         case 0:
2002             RETVAL = termios_ref->c_iflag;
2003             break;
2004         case 1:
2005             RETVAL = termios_ref->c_oflag;
2006             break;
2007         case 2:
2008             RETVAL = termios_ref->c_cflag;
2009             break;
2010         case 3:
2011             RETVAL = termios_ref->c_lflag;
2012             break;
2013         default:
2014             RETVAL = 0; /* silence compiler warning */
2015         }
2016 #else
2017         not_here(GvNAME(CvGV(cv)));
2018         RETVAL = 0;
2019 #endif
2020     OUTPUT:
2021         RETVAL
2022
2023 cc_t
2024 getcc(termios_ref, ccix)
2025         POSIX::Termios  termios_ref
2026         unsigned int    ccix
2027     CODE:
2028 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2029         if (ccix >= NCCS)
2030             croak("Bad getcc subscript");
2031         RETVAL = termios_ref->c_cc[ccix];
2032 #else
2033      not_here("getcc");
2034      RETVAL = 0;
2035 #endif
2036     OUTPUT:
2037         RETVAL
2038
2039 SysRet
2040 setispeed(termios_ref, speed)
2041         POSIX::Termios  termios_ref
2042         speed_t         speed
2043     ALIAS:
2044         setospeed = 1
2045     CODE:
2046         RETVAL = ix
2047             ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
2048     OUTPUT:
2049         RETVAL
2050
2051 void
2052 setiflag(termios_ref, flag)
2053         POSIX::Termios  termios_ref
2054         tcflag_t        flag
2055     ALIAS:
2056         setoflag = 1
2057         setcflag = 2
2058         setlflag = 3
2059     CODE:
2060 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2061         switch(ix) {
2062         case 0:
2063             termios_ref->c_iflag = flag;
2064             break;
2065         case 1:
2066             termios_ref->c_oflag = flag;
2067             break;
2068         case 2:
2069             termios_ref->c_cflag = flag;
2070             break;
2071         case 3:
2072             termios_ref->c_lflag = flag;
2073             break;
2074         }
2075 #else
2076         not_here(GvNAME(CvGV(cv)));
2077 #endif
2078
2079 void
2080 setcc(termios_ref, ccix, cc)
2081         POSIX::Termios  termios_ref
2082         unsigned int    ccix
2083         cc_t            cc
2084     CODE:
2085 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2086         if (ccix >= NCCS)
2087             croak("Bad setcc subscript");
2088         termios_ref->c_cc[ccix] = cc;
2089 #else
2090             not_here("setcc");
2091 #endif
2092
2093
2094 MODULE = POSIX          PACKAGE = POSIX
2095
2096 INCLUDE: const-xs.inc
2097
2098 int
2099 WEXITSTATUS(status)
2100         int status
2101     ALIAS:
2102         POSIX::WIFEXITED = 1
2103         POSIX::WIFSIGNALED = 2
2104         POSIX::WIFSTOPPED = 3
2105         POSIX::WSTOPSIG = 4
2106         POSIX::WTERMSIG = 5
2107     CODE:
2108 #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
2109       || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
2110         RETVAL = 0; /* Silence compilers that notice this, but don't realise
2111                        that not_here() can't return.  */
2112 #endif
2113         switch(ix) {
2114         case 0:
2115 #ifdef WEXITSTATUS
2116             RETVAL = WEXITSTATUS(WMUNGE(status));
2117 #else
2118             not_here("WEXITSTATUS");
2119 #endif
2120             break;
2121         case 1:
2122 #ifdef WIFEXITED
2123             RETVAL = WIFEXITED(WMUNGE(status));
2124 #else
2125             not_here("WIFEXITED");
2126 #endif
2127             break;
2128         case 2:
2129 #ifdef WIFSIGNALED
2130             RETVAL = WIFSIGNALED(WMUNGE(status));
2131 #else
2132             not_here("WIFSIGNALED");
2133 #endif
2134             break;
2135         case 3:
2136 #ifdef WIFSTOPPED
2137             RETVAL = WIFSTOPPED(WMUNGE(status));
2138 #else
2139             not_here("WIFSTOPPED");
2140 #endif
2141             break;
2142         case 4:
2143 #ifdef WSTOPSIG
2144             RETVAL = WSTOPSIG(WMUNGE(status));
2145 #else
2146             not_here("WSTOPSIG");
2147 #endif
2148             break;
2149         case 5:
2150 #ifdef WTERMSIG
2151             RETVAL = WTERMSIG(WMUNGE(status));
2152 #else
2153             not_here("WTERMSIG");
2154 #endif
2155             break;
2156         default:
2157             croak("Illegal alias %d for POSIX::W*", (int)ix);
2158         }
2159     OUTPUT:
2160         RETVAL
2161
2162 SysRet
2163 open(filename, flags = O_RDONLY, mode = 0666)
2164         char *          filename
2165         int             flags
2166         Mode_t          mode
2167     CODE:
2168         if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
2169             TAINT_PROPER("open");
2170         RETVAL = open(filename, flags, mode);
2171     OUTPUT:
2172         RETVAL
2173
2174
2175 HV *
2176 localeconv()
2177     CODE:
2178 #ifndef HAS_LOCALECONV
2179         localeconv(); /* A stub to call not_here(). */
2180 #else
2181         struct lconv *lcbuf;
2182
2183         /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
2184          * LC_MONETARY is already in the correct locale */
2185         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2186         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2187
2188         RETVAL = newHV();
2189         sv_2mortal((SV*)RETVAL);
2190         if ((lcbuf = localeconv())) {
2191             const struct lconv_offset *strings = lconv_strings;
2192             const struct lconv_offset *integers = lconv_integers;
2193             const char *ptr = (const char *) lcbuf;
2194
2195             while (strings->name) {
2196                 /* This string may be controlled by either LC_NUMERIC, or
2197                  * LC_MONETARY */
2198                 bool is_utf8_locale
2199 #if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
2200                  = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name))
2201                                              ? LC_NUMERIC
2202                                              : LC_MONETARY);
2203 #elif defined(USE_LOCALE_NUMERIC)
2204                  = _is_cur_LC_category_utf8(LC_NUMERIC);
2205 #elif defined(USE_LOCALE_MONETARY)
2206                  = _is_cur_LC_category_utf8(LC_MONETARY);
2207 #else
2208                  = FALSE;
2209 #endif
2210
2211                 const char *value = *((const char **)(ptr + strings->offset));
2212
2213                 if (value && *value) {
2214                     (void) hv_store(RETVAL,
2215                         strings->name,
2216                         strlen(strings->name),
2217                         newSVpvn_utf8(value,
2218                                       strlen(value),
2219
2220                                       /* We mark it as UTF-8 if a utf8 locale
2221                                        * and is valid and variant under UTF-8 */
2222                                       is_utf8_locale
2223                                         && ! is_invariant_string((U8 *) value, 0)
2224                                         && is_utf8_string((U8 *) value, 0)),
2225                         0);
2226                 }
2227                 strings++;
2228             }
2229
2230             while (integers->name) {
2231                 const char value = *((const char *)(ptr + integers->offset));
2232
2233                 if (value != CHAR_MAX)
2234                     (void) hv_store(RETVAL, integers->name,
2235                                     strlen(integers->name), newSViv(value), 0);
2236                 integers++;
2237             }
2238         }
2239         RESTORE_LC_NUMERIC_STANDARD();
2240 #endif  /* HAS_LOCALECONV */
2241     OUTPUT:
2242         RETVAL
2243
2244 char *
2245 setlocale(category, locale = 0)
2246         int             category
2247         const char *    locale
2248     PREINIT:
2249         char *          retval;
2250     CODE:
2251 #ifdef USE_LOCALE_NUMERIC
2252         /* A 0 (or NULL) locale means only query what the current one is.  We
2253          * have the LC_NUMERIC name saved, because we are normally switched
2254          * into the C locale for it.  Switch back so an LC_ALL query will yield
2255          * the correct results; all other categories don't require special
2256          * handling */
2257         if (locale == 0) {
2258             if (category == LC_NUMERIC) {
2259                 XSRETURN_PV(PL_numeric_name);
2260             }
2261 #   ifdef LC_ALL
2262             else if (category == LC_ALL) {
2263                 SET_NUMERIC_UNDERLYING();
2264             }
2265 #   endif
2266         }
2267 #endif
2268 #ifdef WIN32    /* Use wrapper on Windows */
2269         retval = Perl_my_setlocale(aTHX_ category, locale);
2270 #else
2271         retval = setlocale(category, locale);
2272 #endif
2273         DEBUG_L(PerlIO_printf(Perl_debug_log,
2274             "%s:%d: %s\n", __FILE__, __LINE__,
2275                 _setlocale_debug_string(category, locale, retval)));
2276         if (! retval) {
2277             /* Should never happen that a query would return an error, but be
2278              * sure and reset to C locale */
2279             if (locale == 0) {
2280                 SET_NUMERIC_STANDARD();
2281             }
2282             XSRETURN_UNDEF;
2283         }
2284
2285         /* Save retval since subsequent setlocale() calls may overwrite it. */
2286         retval = savepv(retval);
2287
2288         /* For locale == 0, we may have switched to NUMERIC_UNDERLYING.  Switch
2289          * back */
2290         if (locale == 0) {
2291             SET_NUMERIC_STANDARD();
2292             XSRETURN_PV(retval);
2293         }
2294         else {
2295             RETVAL = retval;
2296 #ifdef USE_LOCALE_CTYPE
2297             if (category == LC_CTYPE
2298 #ifdef LC_ALL
2299                 || category == LC_ALL
2300 #endif
2301                 )
2302             {
2303                 char *newctype;
2304 #ifdef LC_ALL
2305                 if (category == LC_ALL) {
2306                     newctype = setlocale(LC_CTYPE, NULL);
2307                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2308                         "%s:%d: %s\n", __FILE__, __LINE__,
2309                         _setlocale_debug_string(LC_CTYPE, NULL, newctype)));
2310                 }
2311                 else
2312 #endif
2313                     newctype = RETVAL;
2314                 new_ctype(newctype);
2315             }
2316 #endif /* USE_LOCALE_CTYPE */
2317 #ifdef USE_LOCALE_COLLATE
2318             if (category == LC_COLLATE
2319 #ifdef LC_ALL
2320                 || category == LC_ALL
2321 #endif
2322                 )
2323             {
2324                 char *newcoll;
2325 #ifdef LC_ALL
2326                 if (category == LC_ALL) {
2327                     newcoll = setlocale(LC_COLLATE, NULL);
2328                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2329                         "%s:%d: %s\n", __FILE__, __LINE__,
2330                         _setlocale_debug_string(LC_COLLATE, NULL, newcoll)));
2331                 }
2332                 else
2333 #endif
2334                     newcoll = RETVAL;
2335                 new_collate(newcoll);
2336             }
2337 #endif /* USE_LOCALE_COLLATE */
2338 #ifdef USE_LOCALE_NUMERIC
2339             if (category == LC_NUMERIC
2340 #ifdef LC_ALL
2341                 || category == LC_ALL
2342 #endif
2343                 )
2344             {
2345                 char *newnum;
2346 #ifdef LC_ALL
2347                 if (category == LC_ALL) {
2348                     newnum = setlocale(LC_NUMERIC, NULL);
2349                     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2350                         "%s:%d: %s\n", __FILE__, __LINE__,
2351                         _setlocale_debug_string(LC_NUMERIC, NULL, newnum)));
2352                 }
2353                 else
2354 #endif
2355                     newnum = RETVAL;
2356                 new_numeric(newnum);
2357             }
2358 #endif /* USE_LOCALE_NUMERIC */
2359         }
2360     OUTPUT:
2361         RETVAL
2362     CLEANUP:
2363         Safefree(RETVAL);
2364
2365 NV
2366 acos(x)
2367         NV              x
2368     ALIAS:
2369         acosh = 1
2370         asin = 2
2371         asinh = 3
2372         atan = 4
2373         atanh = 5
2374         cbrt = 6
2375         ceil = 7
2376         cosh = 8
2377         erf = 9
2378         erfc = 10
2379         exp2 = 11
2380         expm1 = 12
2381         floor = 13
2382         j0 = 14
2383         j1 = 15
2384         lgamma = 16
2385         log10 = 17
2386         log1p = 18
2387         log2 = 19
2388         logb = 20
2389         nearbyint = 21
2390         rint = 22
2391         round = 23
2392         sinh = 24
2393         tan = 25
2394         tanh = 26
2395         tgamma = 27
2396         trunc = 28
2397         y0 = 29
2398         y1 = 30
2399     CODE:
2400         PERL_UNUSED_VAR(x);
2401         RETVAL = NV_NAN;
2402         switch (ix) {
2403         case 0:
2404             RETVAL = Perl_acos(x); /* C89 math */
2405             break;
2406         case 1:
2407 #ifdef c99_acosh
2408             RETVAL = c99_acosh(x);
2409 #else
2410             not_here("acosh");
2411 #endif
2412             break;
2413         case 2:
2414             RETVAL = Perl_asin(x); /* C89 math */
2415             break;
2416         case 3:
2417 #ifdef c99_asinh
2418             RETVAL = c99_asinh(x);
2419 #else
2420             not_here("asinh");
2421 #endif
2422             break;
2423         case 4:
2424             RETVAL = Perl_atan(x); /* C89 math */
2425             break;
2426         case 5:
2427 #ifdef c99_atanh
2428             RETVAL = c99_atanh(x);
2429 #else
2430             not_here("atanh");
2431 #endif
2432             break;
2433         case 6:
2434 #ifdef c99_cbrt
2435             RETVAL = c99_cbrt(x);
2436 #else
2437             not_here("cbrt");
2438 #endif
2439             break;
2440         case 7:
2441             RETVAL = Perl_ceil(x); /* C89 math */
2442             break;
2443         case 8:
2444             RETVAL = Perl_cosh(x); /* C89 math */
2445             break;
2446         case 9:
2447 #ifdef c99_erf
2448             RETVAL = c99_erf(x);
2449 #else
2450             not_here("erf");
2451 #endif
2452             break;
2453         case 10:
2454 #ifdef c99_erfc
2455             RETVAL = c99_erfc(x);
2456 #else
2457             not_here("erfc");
2458 #endif
2459             break;
2460         case 11:
2461 #ifdef c99_exp2
2462             RETVAL = c99_exp2(x);
2463 #else
2464             not_here("exp2");
2465 #endif
2466             break;
2467         case 12:
2468 #ifdef c99_expm1
2469             RETVAL = c99_expm1(x);
2470 #else
2471             not_here("expm1");
2472 #endif
2473             break;
2474         case 13:
2475             RETVAL = Perl_floor(x); /* C89 math */
2476             break;
2477         case 14:
2478 #ifdef bessel_j0
2479             RETVAL = bessel_j0(x);
2480 #else
2481             not_here("j0");
2482 #endif
2483             break;
2484         case 15:
2485 #ifdef bessel_j1
2486             RETVAL = bessel_j1(x);
2487 #else
2488             not_here("j1");
2489 #endif
2490             break;
2491         case 16:
2492         /* XXX Note: the lgamma modifies a global variable (signgam),
2493          * which is evil.  Some platforms have lgamma_r, which has
2494          * extra output parameter instead of the global variable. */
2495 #ifdef c99_lgamma
2496             RETVAL = c99_lgamma(x);
2497 #else
2498             not_here("lgamma");
2499 #endif
2500             break;
2501         case 17:
2502             RETVAL = log10(x); /* C89 math */
2503             break;
2504         case 18:
2505 #ifdef c99_log1p
2506             RETVAL = c99_log1p(x);
2507 #else
2508             not_here("log1p");
2509 #endif
2510             break;
2511         case 19:
2512 #ifdef c99_log2
2513             RETVAL = c99_log2(x);
2514 #else
2515             not_here("log2");
2516 #endif
2517             break;
2518         case 20:
2519 #ifdef c99_logb
2520             RETVAL = c99_logb(x);
2521 #elif defined(c99_log2) && FLT_RADIX == 2
2522             RETVAL = Perl_floor(c99_log2(PERL_ABS(x)));
2523 #else
2524             not_here("logb");
2525 #endif
2526             break;
2527         case 21:
2528 #ifdef c99_nearbyint
2529             RETVAL = c99_nearbyint(x);
2530 #else
2531             not_here("nearbyint");
2532 #endif
2533             break;
2534         case 22:
2535 #ifdef c99_rint
2536             RETVAL = c99_rint(x);
2537 #else
2538             not_here("rint");
2539 #endif
2540             break;
2541         case 23:
2542 #ifdef c99_round
2543             RETVAL = c99_round(x);
2544 #else
2545             not_here("round");
2546 #endif
2547             break;
2548         case 24:
2549             RETVAL = Perl_sinh(x); /* C89 math */
2550             break;
2551         case 25:
2552             RETVAL = Perl_tan(x); /* C89 math */
2553             break;
2554         case 26:
2555             RETVAL = Perl_tanh(x); /* C89 math */
2556             break;
2557         case 27:
2558 #ifdef c99_tgamma
2559             RETVAL = c99_tgamma(x);
2560 #else
2561             not_here("tgamma");
2562 #endif
2563             break;
2564         case 28:
2565 #ifdef c99_trunc
2566             RETVAL = c99_trunc(x);
2567 #else
2568             not_here("trunc");
2569 #endif
2570             break;
2571         case 29:
2572 #ifdef bessel_y0
2573             RETVAL = bessel_y0(x);
2574 #else
2575             not_here("y0");
2576 #endif
2577             break;
2578         case 30:
2579         default:
2580 #ifdef bessel_y1
2581             RETVAL = bessel_y1(x);
2582 #else
2583             not_here("y1");
2584 #endif
2585         }
2586     OUTPUT:
2587         RETVAL
2588
2589 IV
2590 fegetround()
2591     CODE:
2592 #ifdef HAS_FEGETROUND
2593         RETVAL = my_fegetround();
2594 #else
2595         RETVAL = -1;
2596         not_here("fegetround");
2597 #endif
2598     OUTPUT:
2599         RETVAL
2600
2601 IV
2602 fesetround(x)
2603         IV      x
2604     CODE:
2605 #ifdef HAS_FEGETROUND /* canary for fesetround */
2606         RETVAL = fesetround(x);
2607 #elif defined(HAS_FPGETROUND) /* canary for fpsetround */
2608         switch (x) {
2609         case FE_TONEAREST:  RETVAL = fpsetround(FP_RN); break;
2610         case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
2611         case FE_DOWNWARD:   RETVAL = fpsetround(FP_RM); break;
2612         case FE_UPWARD:     RETVAL = fpsetround(FP_RP); break;
2613         default: RETVAL = -1; break;
2614         }
2615 #elif defined(__osf__) /* Tru64 */
2616         switch (x) {
2617         case FE_TONEAREST:  RETVAL = write_rnd(FP_RND_RN); break;
2618         case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break;
2619         case FE_DOWNWARD:   RETVAL = write_rnd(FP_RND_RM); break;
2620         case FE_UPWARD:     RETVAL = write_rnd(FP_RND_RP); break;
2621         default: RETVAL = -1; break;
2622         }
2623 #else
2624         PERL_UNUSED_VAR(x);
2625         RETVAL = -1;
2626         not_here("fesetround");
2627 #endif
2628     OUTPUT:
2629         RETVAL
2630
2631 IV
2632 fpclassify(x)
2633         NV              x
2634     ALIAS:
2635         ilogb = 1
2636         isfinite = 2
2637         isinf = 3
2638         isnan = 4
2639         isnormal = 5
2640         lrint = 6
2641         lround = 7
2642         signbit = 8
2643     CODE:
2644         PERL_UNUSED_VAR(x);
2645         RETVAL = -1;
2646         switch (ix) {
2647         case 0:
2648 #ifdef c99_fpclassify
2649             RETVAL = c99_fpclassify(x);
2650 #else
2651             not_here("fpclassify");
2652 #endif
2653             break;
2654         case 1:
2655 #ifdef c99_ilogb
2656             RETVAL = c99_ilogb(x);
2657 #else
2658             not_here("ilogb");
2659 #endif
2660             break;
2661         case 2:
2662             RETVAL = Perl_isfinite(x);
2663             break;
2664         case 3:
2665             RETVAL = Perl_isinf(x);
2666             break;
2667         case 4:
2668             RETVAL = Perl_isnan(x);
2669             break;
2670         case 5:
2671 #ifdef c99_isnormal
2672             RETVAL = c99_isnormal(x);
2673 #else
2674             not_here("isnormal");
2675 #endif
2676             break;
2677         case 6:
2678 #ifdef c99_lrint
2679             RETVAL = c99_lrint(x);
2680 #else
2681             not_here("lrint");
2682 #endif
2683             break;
2684         case 7:
2685 #ifdef c99_lround
2686             RETVAL = c99_lround(x);
2687 #else
2688             not_here("lround");
2689 #endif
2690             break;
2691         case 8:
2692         default:
2693 #ifdef Perl_signbit
2694             RETVAL = Perl_signbit(x);
2695 #else
2696             RETVAL = (x < 0) || (x == -0.0);
2697 #endif
2698             break;
2699         }
2700     OUTPUT:
2701         RETVAL
2702
2703 NV
2704 getpayload(nv)
2705         NV nv
2706     CODE:
2707         RETVAL = S_getpayload(nv);
2708     OUTPUT:
2709         RETVAL
2710
2711 void
2712 setpayload(nv, payload)
2713         NV nv
2714         NV payload
2715     CODE:
2716         S_setpayload(&nv, payload, FALSE);
2717     OUTPUT:
2718         nv
2719
2720 void
2721 setpayloadsig(nv, payload)
2722         NV nv
2723         NV payload
2724     CODE:
2725         nv = NV_NAN;
2726         S_setpayload(&nv, payload, TRUE);
2727     OUTPUT:
2728         nv
2729
2730 int
2731 issignaling(nv)
2732         NV nv
2733     CODE:
2734         RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv);
2735     OUTPUT:
2736         RETVAL
2737
2738 NV
2739 copysign(x,y)
2740         NV              x
2741         NV              y
2742     ALIAS:
2743         fdim = 1
2744         fmax = 2
2745         fmin = 3
2746         fmod = 4
2747         hypot = 5
2748         isgreater = 6
2749         isgreaterequal = 7
2750         isless = 8
2751         islessequal = 9
2752         islessgreater = 10
2753         isunordered = 11
2754         nextafter = 12
2755         nexttoward = 13
2756         remainder = 14
2757     CODE:
2758         PERL_UNUSED_VAR(x);
2759         PERL_UNUSED_VAR(y);
2760         RETVAL = NV_NAN;
2761         switch (ix) {
2762         case 0:
2763 #ifdef c99_copysign
2764             RETVAL = c99_copysign(x, y);
2765 #else
2766             not_here("copysign");
2767 #endif
2768             break;
2769         case 1:
2770 #ifdef c99_fdim
2771             RETVAL = c99_fdim(x, y);
2772 #else
2773             not_here("fdim");
2774 #endif
2775             break;
2776         case 2:
2777 #ifdef c99_fmax
2778             RETVAL = c99_fmax(x, y);
2779 #else
2780             not_here("fmax");
2781 #endif
2782             break;
2783         case 3:
2784 #ifdef c99_fmin
2785             RETVAL = c99_fmin(x, y);
2786 #else
2787             not_here("fmin");
2788 #endif
2789             break;
2790         case 4:
2791             RETVAL = Perl_fmod(x, y); /* C89 math */
2792             break;
2793         case 5:
2794 #ifdef c99_hypot
2795             RETVAL = c99_hypot(x, y);
2796 #else
2797             not_here("hypot");
2798 #endif
2799             break;
2800         case 6:
2801 #ifdef c99_isgreater
2802             RETVAL = c99_isgreater(x, y);
2803 #else
2804             not_here("isgreater");
2805 #endif
2806             break;
2807         case 7:
2808 #ifdef c99_isgreaterequal
2809             RETVAL = c99_isgreaterequal(x, y);
2810 #else
2811             not_here("isgreaterequal");
2812 #endif
2813             break;
2814         case 8:
2815 #ifdef c99_isless
2816             RETVAL = c99_isless(x, y);
2817 #else
2818             not_here("isless");
2819 #endif
2820             break;
2821         case 9:
2822 #ifdef c99_islessequal
2823             RETVAL = c99_islessequal(x, y);
2824 #else
2825             not_here("islessequal");
2826 #endif
2827             break;
2828         case 10:
2829 #ifdef c99_islessgreater
2830             RETVAL = c99_islessgreater(x, y);
2831 #else
2832             not_here("islessgreater");
2833 #endif
2834             break;
2835         case 11:
2836 #ifdef c99_isunordered
2837             RETVAL = c99_isunordered(x, y);
2838 #else
2839             not_here("isunordered");
2840 #endif
2841             break;
2842         case 12:
2843 #ifdef c99_nextafter
2844             RETVAL = c99_nextafter(x, y);
2845 #else
2846             not_here("nextafter");
2847 #endif
2848             break;
2849         case 13:
2850 #ifdef c99_nexttoward
2851             RETVAL = c99_nexttoward(x, y);
2852 #else
2853             not_here("nexttoward");
2854 #endif
2855             break;
2856         case 14:
2857         default:
2858 #ifdef c99_remainder
2859           RETVAL = c99_remainder(x, y);
2860 #else
2861           not_here("remainder");
2862 #endif
2863             break;
2864         }
2865         OUTPUT:
2866             RETVAL
2867
2868 void
2869 frexp(x)
2870         NV              x
2871     PPCODE:
2872         int expvar;
2873         /* (We already know stack is long enough.) */
2874         PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2875         PUSHs(sv_2mortal(newSViv(expvar)));
2876
2877 NV
2878 ldexp(x,exp)
2879         NV              x
2880         int             exp
2881
2882 void
2883 modf(x)
2884         NV              x
2885     PPCODE:
2886         NV intvar;
2887         /* (We already know stack is long enough.) */
2888         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2889         PUSHs(sv_2mortal(newSVnv(intvar)));
2890
2891 void
2892 remquo(x,y)
2893         NV              x
2894         NV              y
2895     PPCODE:
2896 #ifdef c99_remquo
2897         int intvar;
2898         PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2899         PUSHs(sv_2mortal(newSVnv(intvar)));
2900 #else
2901         PERL_UNUSED_VAR(x);
2902         PERL_UNUSED_VAR(y);
2903         not_here("remquo");
2904 #endif
2905
2906 NV
2907 scalbn(x,y)
2908         NV              x
2909         IV              y
2910     CODE:
2911 #ifdef c99_scalbn
2912         RETVAL = c99_scalbn(x, y);
2913 #else
2914         PERL_UNUSED_VAR(x);
2915         PERL_UNUSED_VAR(y);
2916         RETVAL = NV_NAN;
2917         not_here("scalbn");
2918 #endif
2919     OUTPUT:
2920         RETVAL
2921
2922 NV
2923 fma(x,y,z)
2924         NV              x
2925         NV              y
2926         NV              z
2927     CODE:
2928 #ifdef c99_fma
2929         RETVAL = c99_fma(x, y, z);
2930 #else
2931         PERL_UNUSED_VAR(x);
2932         PERL_UNUSED_VAR(y);
2933         PERL_UNUSED_VAR(z);
2934         not_here("fma");
2935 #endif
2936     OUTPUT:
2937         RETVAL
2938
2939 NV
2940 nan(payload = 0)
2941         NV payload
2942     CODE:
2943 #ifdef NV_NAN
2944         /* If no payload given, just return the default NaN.
2945          * This makes a difference in platforms where the default
2946          * NaN is not all zeros. */
2947         if (items == 0) {
2948           RETVAL = NV_NAN;
2949         } else {
2950           S_setpayload(&RETVAL, payload, FALSE);
2951         }
2952 #elif defined(c99_nan)
2953         {
2954           STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", nv);
2955           if ((IV)elen == -1) {
2956             RETVAL = NV_NAN;
2957           } else {
2958             RETVAL = c99_nan(PL_efloatbuf);
2959           }
2960         }
2961 #else
2962         not_here("nan");
2963 #endif
2964     OUTPUT:
2965         RETVAL
2966
2967 NV
2968 jn(x,y)
2969         IV              x
2970         NV              y
2971     ALIAS:
2972         yn = 1
2973     CODE:
2974         RETVAL = NV_NAN;
2975         switch (ix) {
2976         case 0:
2977 #ifdef bessel_jn
2978           RETVAL = bessel_jn(x, y);
2979 #else
2980           PERL_UNUSED_VAR(x);
2981           PERL_UNUSED_VAR(y);
2982           not_here("jn");
2983 #endif
2984             break;
2985         case 1:
2986         default:
2987 #ifdef bessel_yn
2988           RETVAL = bessel_yn(x, y);
2989 #else
2990           PERL_UNUSED_VAR(x);
2991           PERL_UNUSED_VAR(y);
2992           not_here("yn");
2993 #endif
2994             break;
2995         }
2996     OUTPUT:
2997         RETVAL
2998
2999 SysRet
3000 sigaction(sig, optaction, oldaction = 0)
3001         int                     sig
3002         SV *                    optaction
3003         POSIX::SigAction        oldaction
3004     CODE:
3005 #if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__))
3006         RETVAL = not_here("sigaction");
3007 #else
3008 # This code is really grody because we are trying to make the signal
3009 # interface look beautiful, which is hard.
3010
3011         {
3012             dVAR;
3013             POSIX__SigAction action;
3014             GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
3015             struct sigaction act;
3016             struct sigaction oact;
3017             sigset_t sset;
3018             SV *osset_sv;
3019             sigset_t osset;
3020             POSIX__SigSet sigset;
3021             SV** svp;
3022             SV** sigsvp;
3023
3024             if (sig < 0) {
3025                 croak("Negative signals are not allowed");
3026             }
3027
3028             if (sig == 0 && SvPOK(ST(0))) {
3029                 const char *s = SvPVX_const(ST(0));
3030                 int i = whichsig(s);
3031
3032                 if (i < 0 && memEQ(s, "SIG", 3))
3033                     i = whichsig(s + 3);
3034                 if (i < 0) {
3035                     if (ckWARN(WARN_SIGNAL))
3036                         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3037                                     "No such signal: SIG%s", s);
3038                     XSRETURN_UNDEF;
3039                 }
3040                 else
3041                     sig = i;
3042             }
3043 #ifdef NSIG
3044             if (sig > NSIG) { /* NSIG - 1 is still okay. */
3045                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3046                             "No such signal: %d", sig);
3047                 XSRETURN_UNDEF;
3048             }
3049 #endif
3050             sigsvp = hv_fetch(GvHVn(siggv),
3051                               PL_sig_name[sig],
3052                               strlen(PL_sig_name[sig]),
3053                               TRUE);
3054
3055             /* Check optaction and set action */
3056             if(SvTRUE(optaction)) {
3057                 if(sv_isa(optaction, "POSIX::SigAction"))
3058                         action = (HV*)SvRV(optaction);
3059                 else
3060                         croak("action is not of type POSIX::SigAction");
3061             }
3062             else {
3063                 action=0;
3064             }
3065
3066             /* sigaction() is supposed to look atomic. In particular, any
3067              * signal handler invoked during a sigaction() call should
3068              * see either the old or the new disposition, and not something
3069              * in between. We use sigprocmask() to make it so.
3070              */
3071             sigfillset(&sset);
3072             RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
3073             if(RETVAL == -1)
3074                XSRETURN_UNDEF;
3075             ENTER;
3076             /* Restore signal mask no matter how we exit this block. */
3077             osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
3078             SAVEFREESV( osset_sv );
3079             SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
3080
3081             RETVAL=-1; /* In case both oldaction and action are 0. */
3082
3083             /* Remember old disposition if desired. */
3084             if (oldaction) {
3085                 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
3086                 if(!svp)
3087                     croak("Can't supply an oldaction without a HANDLER");
3088                 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
3089                         sv_setsv(*svp, *sigsvp);
3090                 }
3091                 else {
3092                         sv_setpvs(*svp, "DEFAULT");
3093                 }
3094                 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
3095                 if(RETVAL == -1) {
3096                    LEAVE;
3097                    XSRETURN_UNDEF;
3098                 }
3099                 /* Get back the mask. */
3100                 svp = hv_fetchs(oldaction, "MASK", TRUE);
3101                 if (sv_isa(*svp, "POSIX::SigSet")) {
3102                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3103                 }
3104                 else {
3105                     sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
3106                                                           sizeof(sigset_t),
3107                                                           "POSIX::SigSet");
3108                 }
3109                 *sigset = oact.sa_mask;
3110
3111                 /* Get back the flags. */
3112                 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
3113                 sv_setiv(*svp, oact.sa_flags);
3114
3115                 /* Get back whether the old handler used safe signals. */
3116                 svp = hv_fetchs(oldaction, "SAFE", TRUE);
3117                 sv_setiv(*svp,
3118                 /* compare incompatible pointers by casting to integer */
3119                     PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
3120             }
3121
3122             if (action) {
3123                 /* Safe signals use "csighandler", which vectors through the
3124                    PL_sighandlerp pointer when it's safe to do so.
3125                    (BTW, "csighandler" is very different from "sighandler".) */
3126                 svp = hv_fetchs(action, "SAFE", FALSE);
3127                 act.sa_handler =
3128                         DPTR2FPTR(
3129                             void (*)(int),
3130                             (*svp && SvTRUE(*svp))
3131                                 ? PL_csighandlerp : PL_sighandlerp
3132                         );
3133
3134                 /* Vector new Perl handler through %SIG.
3135                    (The core signal handlers read %SIG to dispatch.) */
3136                 svp = hv_fetchs(action, "HANDLER", FALSE);
3137                 if (!svp)
3138                     croak("Can't supply an action without a HANDLER");
3139                 sv_setsv(*sigsvp, *svp);
3140
3141                 /* This call actually calls sigaction() with almost the
3142                    right settings, including appropriate interpretation
3143                    of DEFAULT and IGNORE.  However, why are we doing
3144                    this when we're about to do it again just below?  XXX */
3145                 SvSETMAGIC(*sigsvp);
3146
3147                 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
3148                 if(SvPOK(*svp)) {
3149                         const char *s=SvPVX_const(*svp);
3150                         if(strEQ(s,"IGNORE")) {
3151                                 act.sa_handler = SIG_IGN;
3152                         }
3153                         else if(strEQ(s,"DEFAULT")) {
3154                                 act.sa_handler = SIG_DFL;
3155                         }
3156                 }
3157
3158                 /* Set up any desired mask. */
3159                 svp = hv_fetchs(action, "MASK", FALSE);
3160                 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
3161                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3162                     act.sa_mask = *sigset;
3163                 }
3164                 else
3165                     sigemptyset(& act.sa_mask);
3166
3167                 /* Set up any desired flags. */
3168                 svp = hv_fetchs(action, "FLAGS", FALSE);
3169                 act.sa_flags = svp ? SvIV(*svp) : 0;
3170
3171                 /* Don't worry about cleaning up *sigsvp if this fails,
3172                  * because that means we tried to disposition a
3173                  * nonblockable signal, in which case *sigsvp is
3174                  * essentially meaningless anyway.
3175                  */
3176                 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
3177                 if(RETVAL == -1) {
3178                     LEAVE;
3179                     XSRETURN_UNDEF;
3180                 }
3181             }
3182
3183             LEAVE;
3184         }
3185 #endif
3186     OUTPUT:
3187         RETVAL
3188
3189 SysRet
3190 sigpending(sigset)
3191         POSIX::SigSet           sigset
3192     ALIAS:
3193         sigsuspend = 1
3194     CODE:
3195 #ifdef __amigaos4__
3196         RETVAL = not_here("sigpending");
3197 #else
3198         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
3199 #endif
3200     OUTPUT:
3201         RETVAL
3202     CLEANUP:
3203     PERL_ASYNC_CHECK();
3204
3205 SysRet
3206 sigprocmask(how, sigset, oldsigset = 0)
3207         int                     how
3208         POSIX::SigSet           sigset = NO_INIT
3209         POSIX::SigSet           oldsigset = NO_INIT
3210 INIT:
3211         if (! SvOK(ST(1))) {
3212             sigset = NULL;
3213         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
3214             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
3215         } else {
3216             croak("sigset is not of type POSIX::SigSet");
3217         }
3218
3219         if (items < 3 || ! SvOK(ST(2))) {
3220             oldsigset = NULL;
3221         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
3222             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
3223         } else {
3224             croak("oldsigset is not of type POSIX::SigSet");
3225         }
3226
3227 void
3228 _exit(status)
3229         int             status
3230
3231 SysRet
3232 dup2(fd1, fd2)
3233         int             fd1
3234         int             fd2
3235     CODE:
3236         if (fd1 >= 0 && fd2 >= 0) {
3237 #ifdef WIN32
3238             /* RT #98912 - More Microsoft muppetry - failing to
3239                actually implemented the well known documented POSIX
3240                behaviour for a POSIX API.
3241                http://msdn.microsoft.com/en-us/library/8syseb29.aspx  */
3242             RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
3243 #else
3244             RETVAL = dup2(fd1, fd2);
3245 #endif
3246         } else {
3247             SETERRNO(EBADF,RMS_IFI);
3248             RETVAL = -1;
3249         }
3250     OUTPUT:
3251         RETVAL
3252
3253 SV *
3254 lseek(fd, offset, whence)
3255         int             fd
3256         Off_t           offset
3257         int             whence
3258     CODE:
3259         if (fd >= 0) {
3260             Off_t pos = PerlLIO_lseek(fd, offset, whence);
3261             RETVAL = sizeof(Off_t) > sizeof(IV)
3262               ? newSVnv((NV)pos) : newSViv((IV)pos);
3263         } else {
3264             SETERRNO(EBADF,RMS_IFI);
3265             RETVAL = newSViv(-1);
3266         }
3267     OUTPUT:
3268         RETVAL
3269
3270 void
3271 nice(incr)
3272         int             incr
3273     PPCODE:
3274         errno = 0;
3275         if ((incr = nice(incr)) != -1 || errno == 0) {
3276             if (incr == 0)
3277                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
3278             else
3279                 XPUSHs(sv_2mortal(newSViv(incr)));
3280         }
3281
3282 void
3283 pipe()
3284     PPCODE:
3285         int fds[2];
3286         if (pipe(fds) != -1) {
3287             EXTEND(SP,2);
3288             PUSHs(sv_2mortal(newSViv(fds[0])));
3289             PUSHs(sv_2mortal(newSViv(fds[1])));
3290         }
3291
3292 SysRet
3293 read(fd, buffer, nbytes)
3294     PREINIT:
3295         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3296     INPUT:
3297         int             fd
3298         size_t          nbytes
3299         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
3300     CLEANUP:
3301         if (RETVAL >= 0) {
3302             SvCUR_set(sv_buffer, RETVAL);
3303             SvPOK_only(sv_buffer);
3304             *SvEND(sv_buffer) = '\0';
3305             SvTAINTED_on(sv_buffer);
3306         }
3307
3308 SysRet
3309 setpgid(pid, pgid)
3310         pid_t           pid
3311         pid_t           pgid
3312
3313 pid_t
3314 setsid()
3315
3316 pid_t
3317 tcgetpgrp(fd)
3318         int             fd
3319
3320 SysRet
3321 tcsetpgrp(fd, pgrp_id)
3322         int             fd
3323         pid_t           pgrp_id
3324
3325 void
3326 uname()
3327     PPCODE:
3328 #ifdef HAS_UNAME
3329         struct utsname buf;
3330         if (uname(&buf) >= 0) {
3331             EXTEND(SP, 5);
3332             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
3333             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
3334             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
3335             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
3336             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
3337         }
3338 #else
3339         uname((char *) 0); /* A stub to call not_here(). */
3340 #endif
3341
3342 SysRet
3343 write(fd, buffer, nbytes)
3344         int             fd
3345         char *          buffer
3346         size_t          nbytes
3347
3348 SV *
3349 tmpnam()
3350     PREINIT:
3351         STRLEN i;
3352         int len;
3353     CODE:
3354         RETVAL = newSVpvs("");
3355         SvGROW(RETVAL, L_tmpnam);
3356         /* Yes, we know tmpnam() is bad.  So bad that some compilers
3357          * and linkers warn against using it.  But it is here for
3358          * completeness.  POSIX.pod warns against using it.
3359          *
3360          * Then again, maybe this should be removed at some point.
3361          * No point in enabling dangerous interfaces. */
3362         if (ckWARN_d(WARN_DEPRECATED)) {
3363             HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI);
3364             if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) {
3365                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Calling POSIX::tmpnam() is deprecated");
3366                 (void)hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0);
3367             }
3368         }
3369         len = strlen(tmpnam(SvPV(RETVAL, i)));
3370         SvCUR_set(RETVAL, len);
3371     OUTPUT:
3372         RETVAL
3373
3374 void
3375 abort()
3376
3377 int
3378 mblen(s, n)
3379         char *          s
3380         size_t          n
3381
3382 size_t
3383 mbstowcs(s, pwcs, n)
3384         wchar_t *       s
3385         char *          pwcs
3386         size_t          n
3387
3388 int
3389 mbtowc(pwc, s, n)
3390         wchar_t *       pwc
3391         char *          s
3392         size_t          n
3393
3394 int
3395 wcstombs(s, pwcs, n)
3396         char *          s
3397         wchar_t *       pwcs
3398         size_t          n
3399
3400 int
3401 wctomb(s, wchar)
3402         char *          s
3403         wchar_t         wchar
3404
3405 int
3406 strcoll(s1, s2)
3407         char *          s1
3408         char *          s2
3409
3410 void
3411 strtod(str)
3412         char *          str
3413     PREINIT:
3414         double num;
3415         char *unparsed;
3416     PPCODE:
3417         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3418         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3419         num = strtod(str, &unparsed);
3420         PUSHs(sv_2mortal(newSVnv(num)));
3421         if (GIMME_V == G_ARRAY) {
3422             EXTEND(SP, 1);
3423             if (unparsed)
3424                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3425             else
3426                 PUSHs(&PL_sv_undef);
3427         }
3428         RESTORE_LC_NUMERIC_STANDARD();
3429
3430 #ifdef HAS_STRTOLD
3431
3432 void
3433 strtold(str)
3434         char *          str
3435     PREINIT:
3436         long double num;
3437         char *unparsed;
3438     PPCODE:
3439         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3440         STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3441         num = strtold(str, &unparsed);
3442         PUSHs(sv_2mortal(newSVnv(num)));
3443         if (GIMME_V == G_ARRAY) {
3444             EXTEND(SP, 1);
3445             if (unparsed)
3446                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3447             else
3448                 PUSHs(&PL_sv_undef);
3449         }
3450         RESTORE_LC_NUMERIC_STANDARD();
3451
3452 #endif
3453
3454 void
3455 strtol(str, base = 0)
3456         char *          str
3457         int             base
3458     PREINIT:
3459         long num;
3460         char *unparsed;
3461     PPCODE:
3462         if (base == 0 || (base >= 2 && base <= 36)) {
3463             num = strtol(str, &unparsed, base);
3464 #if IVSIZE < LONGSIZE
3465             if (num < IV_MIN || num > IV_MAX)
3466                 PUSHs(sv_2mortal(newSVnv((double)num)));
3467             else
3468 #endif
3469                 PUSHs(sv_2mortal(newSViv((IV)num)));
3470             if (GIMME_V == G_ARRAY) {
3471                 EXTEND(SP, 1);
3472                 if (unparsed)
3473                     PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3474                 else
3475                     PUSHs(&PL_sv_undef);
3476             }
3477         } else {
3478             SETERRNO(EINVAL, LIB_INVARG);
3479             PUSHs(&PL_sv_undef);
3480             if (GIMME_V == G_ARRAY) {
3481                EXTEND(SP, 1);
3482                PUSHs(&PL_sv_undef);
3483             }
3484         }
3485
3486 void
3487 strtoul(str, base = 0)
3488         const char *    str
3489         int             base
3490     PREINIT:
3491         unsigned long num;
3492         char *unparsed;
3493     PPCODE:
3494         PERL_UNUSED_VAR(str);
3495         PERL_UNUSED_VAR(base);
3496         if (base == 0 || (base >= 2 && base <= 36)) {
3497             num = strtoul(str, &unparsed, base);
3498 #if IVSIZE <= LONGSIZE
3499             if (num > IV_MAX)
3500                 PUSHs(sv_2mortal(newSVnv((double)num)));
3501             else
3502 #endif
3503                 PUSHs(sv_2mortal(newSViv((IV)num)));
3504             if (GIMME_V == G_ARRAY) {
3505                 EXTEND(SP, 1);
3506                 if (unparsed)
3507                     PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3508                 else
3509                   PUSHs(&PL_sv_undef);
3510             }
3511         } else {
3512             SETERRNO(EINVAL, LIB_INVARG);
3513             PUSHs(&PL_sv_undef);
3514             if (GIMME_V == G_ARRAY) {
3515                EXTEND(SP, 1);
3516                PUSHs(&PL_sv_undef);
3517             }
3518         }
3519
3520 void
3521 strxfrm(src)
3522         SV *            src
3523     CODE:
3524         {
3525           STRLEN srclen;
3526           STRLEN dstlen;
3527           STRLEN buflen;
3528           char *p = SvPV(src,srclen);
3529           srclen++;
3530           buflen = srclen * 4 + 1;
3531           ST(0) = sv_2mortal(newSV(buflen));
3532           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen);
3533           if (dstlen >= buflen) {
3534               dstlen++;
3535               SvGROW(ST(0), dstlen);
3536               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
3537               dstlen--;
3538           }
3539           SvCUR_set(ST(0), dstlen);
3540             SvPOK_only(ST(0));
3541         }
3542
3543 SysRet
3544 mkfifo(filename, mode)
3545         char *          filename
3546         Mode_t          mode
3547     ALIAS:
3548         access = 1
3549     CODE:
3550         if(ix) {
3551             RETVAL = access(filename, mode);
3552         } else {
3553             TAINT_PROPER("mkfifo");
3554             RETVAL = mkfifo(filename, mode);
3555         }
3556     OUTPUT:
3557         RETVAL
3558
3559 SysRet
3560 tcdrain(fd)
3561         int             fd
3562     ALIAS:
3563         close = 1
3564         dup = 2
3565     CODE:
3566         if (fd >= 0) {
3567             RETVAL = ix == 1 ? close(fd)
3568               : (ix < 1 ? tcdrain(fd) : dup(fd));
3569         } else {
3570             SETERRNO(EBADF,RMS_IFI);
3571             RETVAL = -1;
3572         }
3573     OUTPUT:
3574         RETVAL
3575
3576
3577 SysRet
3578 tcflow(fd, action)
3579         int             fd
3580         int             action
3581     ALIAS:
3582         tcflush = 1
3583         tcsendbreak = 2
3584     CODE:
3585         if (fd >= 0 && action >= 0) {
3586             RETVAL = ix == 1 ? tcflush(fd, action)
3587               : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
3588         } else {
3589             SETERRNO(EBADF,RMS_IFI);
3590             RETVAL = -1;
3591         }
3592     OUTPUT:
3593         RETVAL
3594
3595 void
3596 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
3597         int             sec
3598         int             min
3599         int             hour
3600         int             mday
3601         int             mon
3602         int             year
3603         int             wday
3604         int             yday
3605         int             isdst
3606     ALIAS:
3607         mktime = 1
3608     PPCODE:
3609         {
3610             dXSTARG;
3611             struct tm mytm;
3612             init_tm(&mytm);     /* XXX workaround - see init_tm() in core util.c */
3613             mytm.tm_sec = sec;
3614             mytm.tm_min = min;
3615             mytm.tm_hour = hour;
3616             mytm.tm_mday = mday;
3617             mytm.tm_mon = mon;
3618             mytm.tm_year = year;
3619             mytm.tm_wday = wday;
3620             mytm.tm_yday = yday;
3621             mytm.tm_isdst = isdst;
3622             if (ix) {
3623                 const time_t result = mktime(&mytm);
3624                 if (result == (time_t)-1)
3625                     SvOK_off(TARG);
3626                 else if (result == 0)
3627                     sv_setpvn(TARG, "0 but true", 10);
3628                 else
3629                     sv_setiv(TARG, (IV)result);
3630             } else {
3631                 sv_setpv(TARG, asctime(&mytm));
3632             }
3633             ST(0) = TARG;
3634             XSRETURN(1);
3635         }
3636
3637 long
3638 clock()
3639
3640 char *
3641 ctime(time)
3642         Time_t          &time
3643
3644 void
3645 times()
3646         PPCODE:
3647         struct tms tms;
3648         clock_t realtime;
3649         realtime = times( &tms );
3650         EXTEND(SP,5);
3651         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
3652         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
3653         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
3654         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
3655         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
3656
3657 double
3658 difftime(time1, time2)
3659         Time_t          time1
3660         Time_t          time2
3661
3662 #XXX: if $xsubpp::WantOptimize is always the default
3663 #     sv_setpv(TARG, ...) could be used rather than
3664 #     ST(0) = sv_2mortal(newSVpv(...))
3665 void
3666 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
3667         SV *            fmt
3668         int             sec
3669         int             min
3670         int             hour
3671         int             mday
3672         int             mon
3673         int             year
3674         int             wday
3675         int             yday
3676         int             isdst
3677     CODE:
3678         {
3679             char *buf;
3680             SV *sv;
3681
3682             /* allowing user-supplied (rather than literal) formats
3683              * is normally frowned upon as a potential security risk;
3684              * but this is part of the API so we have to allow it */
3685             GCC_DIAG_IGNORE(-Wformat-nonliteral);
3686             buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
3687             GCC_DIAG_RESTORE;
3688             sv = sv_newmortal();
3689             if (buf) {
3690                 STRLEN len = strlen(buf);
3691                 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL);
3692                 if (SvUTF8(fmt)
3693                     || (! is_invariant_string((U8*) buf, len)
3694                         && is_utf8_string((U8*) buf, len)
3695 #ifdef USE_LOCALE_TIME
3696                         && _is_cur_LC_category_utf8(LC_TIME)
3697 #endif
3698                 )) {
3699                     SvUTF8_on(sv);
3700                 }
3701             }
3702             else {  /* We can't distinguish between errors and just an empty
3703                      * return; in all cases just return an empty string */
3704                 SvUPGRADE(sv, SVt_PV);
3705                 SvPV_set(sv, (char *) "");
3706                 SvPOK_on(sv);
3707                 SvCUR_set(sv, 0);
3708                 SvLEN_set(sv, 0);   /* Won't attempt to free the string when sv
3709                                        gets destroyed */
3710             }
3711             ST(0) = sv;
3712         }
3713
3714 void
3715 tzset()
3716   PPCODE:
3717     my_tzset(aTHX);
3718
3719 void
3720 tzname()
3721     PPCODE:
3722         EXTEND(SP,2);
3723         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
3724         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
3725
3726 char *
3727 ctermid(s = 0)
3728         char *          s = 0;
3729     CODE:
3730 #ifdef HAS_CTERMID_R
3731         s = (char *) safemalloc((size_t) L_ctermid);
3732 #endif
3733         RETVAL = ctermid(s);
3734     OUTPUT:
3735         RETVAL
3736     CLEANUP:
3737 #ifdef HAS_CTERMID_R
3738         Safefree(s);
3739 #endif
3740
3741 char *
3742 cuserid(s = 0)
3743         char *          s = 0;
3744     CODE:
3745 #ifdef HAS_CUSERID
3746   RETVAL = cuserid(s);
3747 #else
3748   PERL_UNUSED_VAR(s);
3749   RETVAL = 0;
3750   not_here("cuserid");
3751 #endif
3752     OUTPUT:
3753   RETVAL
3754
3755 SysRetLong
3756 fpathconf(fd, name)
3757         int             fd
3758         int             name
3759
3760 SysRetLong
3761 pathconf(filename, name)
3762         char *          filename
3763         int             name
3764
3765 SysRet
3766 pause()
3767     CLEANUP:
3768     PERL_ASYNC_CHECK();
3769
3770 unsigned int
3771 sleep(seconds)
3772         unsigned int    seconds
3773     CODE:
3774         RETVAL = PerlProc_sleep(seconds);
3775     OUTPUT:
3776         RETVAL
3777
3778 SysRet
3779 setgid(gid)
3780         Gid_t           gid
3781
3782 SysRet
3783 setuid(uid)
3784         Uid_t           uid
3785
3786 SysRetLong
3787 sysconf(name)
3788         int             name
3789
3790 char *
3791 ttyname(fd)
3792         int             fd
3793
3794 void
3795 getcwd()
3796     PPCODE:
3797       {
3798         dXSTARG;
3799         getcwd_sv(TARG);
3800         XSprePUSH; PUSHTARG;
3801       }
3802
3803 SysRet
3804 lchown(uid, gid, path)
3805        Uid_t           uid
3806        Gid_t           gid
3807        char *          path
3808     CODE:
3809 #ifdef HAS_LCHOWN
3810        /* yes, the order of arguments is different,
3811         * but consistent with CORE::chown() */
3812        RETVAL = lchown(path, uid, gid);
3813 #else
3814        PERL_UNUSED_VAR(uid);
3815        PERL_UNUSED_VAR(gid);
3816        PERL_UNUSED_VAR(path);
3817        RETVAL = not_here("lchown");
3818 #endif
3819     OUTPUT:
3820        RETVAL